From: Jarkko Hietaniemi Date: Fri, 15 Dec 2000 15:11:05 +0000 (+0000) Subject: This seems to be a stage sane and stable enough to checkin. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=98a29390254d3cb423096b6282689bfe2a7e6a13;p=p5sagit%2Fp5-mst-13.2.git This seems to be a stage sane and stable enough to checkin. (it basically is 8102..8118+8122 but no 8120, 8121, 8123, 8124) p4raw-id: //depot/perl@8125 --- diff --git a/MANIFEST b/MANIFEST index 6fe1fb1..49f6e34 100644 --- a/MANIFEST +++ b/MANIFEST @@ -192,11 +192,6 @@ ext/DynaLoader/hints/netbsd.pl Hint for DynaLoader for named architecture ext/DynaLoader/hints/openbsd.pl Hint for DynaLoader for named architecture ext/Encode/Encode.pm Encode extension ext/Encode/Encode.xs Encode extension -ext/Encode/encode.h Encode extension -ext/Encode/encengine.c Encode extension -ext/Encode/compile Encode extension -ext/Encode/Makefile.PL Encode extension -ext/Encode/Todo Encode extension ext/Encode/Encode/EncodeFormat.pod Encoding table format ext/Encode/Encode/ascii.enc Encoding tables ext/Encode/Encode/big5.enc Encoding tables @@ -279,6 +274,8 @@ ext/Encode/Encode/macUkraine.enc Encoding tables ext/Encode/Encode/posix-bc.enc Encoding tables ext/Encode/Encode/shiftjis.enc Encoding tables ext/Encode/Encode/symbol.enc Encoding tables +ext/Encode/Makefile.PL Encode extension +ext/Encode/Todo Encode extension ext/Encode/compile Encode extension ext/Encode/encengine.c Encode extension ext/Encode/encode.h Encode extension @@ -406,8 +403,8 @@ ext/Socket/Makefile.PL Socket extension makefile writer ext/Socket/Socket.pm Socket extension Perl module ext/Socket/Socket.xs Socket extension external subroutines ext/Storable/ChangeLog Storable extension -ext/Storable/Makefile.PL Storable extension ext/Storable/MANIFEST Storable extension +ext/Storable/Makefile.PL Storable extension ext/Storable/README Storable extension ext/Storable/Storable.pm Storable extension ext/Storable/Storable.xs Storable extension @@ -453,8 +450,8 @@ ext/re/re.pm re extension Perl module ext/re/re.xs re extension external subroutines ext/util/make_ext Used by Makefile to execute extension Makefiles ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info -fakethr.h Fake threads header fakesdio.h stdio in terms of PerlIO +fakethr.h Fake threads header form.h Public declarations for the above global.sym Symbols that need hiding when embedded globals.c File to declare global symbols (for shared library) @@ -682,13 +679,13 @@ lib/File/DosGlob.pm Win32 DOS-globbing module lib/File/Find.pm Routines to do a find lib/File/Path.pm Do things like `mkdir -p' and `rm -r' lib/File/Spec.pm portable operations on file names +lib/File/Spec/Epoc.pm portable operations on EPOC file names lib/File/Spec/Functions.pm Function interface to File::Spec object methods lib/File/Spec/Mac.pm portable operations on Mac file names lib/File/Spec/OS2.pm portable operations on OS2 file names lib/File/Spec/Unix.pm portable operations on Unix file names lib/File/Spec/VMS.pm portable operations on VMS file names lib/File/Spec/Win32.pm portable operations on Win32 file names -lib/File/Spec/Epoc.pm portable operations on EPOC file names lib/File/Temp.pm create safe temporary files and file handles lib/File/stat.pm By-name interface to Perl's builtin stat lib/FileCache.pm Keep more files open than the system permits @@ -1166,8 +1163,8 @@ perlapi.c Perl API functions perlapi.h Perl API function declarations perlio.c C code for PerlIO abstraction perlio.h PerlIO abstraction -perliol.h PerlIO Layer definition perlio.sym Symbols for PerlIO abstraction +perliol.h PerlIO Layer definition perlsdio.h Fake stdio using perlio perlsfio.h Prototype sfio mapping for PerlIO perlsh A poor man's perl shell @@ -1389,9 +1386,9 @@ t/lib/dprof/test6_t Perl code profiler tests t/lib/dprof/test6_v Perl code profiler tests t/lib/dumper-ovl.t See if Data::Dumper works for overloaded data t/lib/dumper.t See if Data::Dumper works +t/lib/encode.t See if Encode works t/lib/english.t See if English works t/lib/env-array.t See if Env works for arrays -t/lib/encode.t See if Encode works t/lib/env.t See if Env works t/lib/errno.t See if Errno works t/lib/fatal.t See if Fatal works @@ -1403,8 +1400,8 @@ t/lib/filefunc.t See if File::Spec::Functions works t/lib/filehand.t See if FileHandle works t/lib/filepath.t See if File::Path works t/lib/filespec.t See if File::Spec works -t/lib/filter-util.t See if Filter::Util::Call works t/lib/filter-util.pl See if Filter::Util::Call works +t/lib/filter-util.t See if Filter::Util::Call works t/lib/findbin.t See if FindBin works t/lib/ftmp-mktemp.t See if File::Temp works t/lib/ftmp-posix.t See if File::Temp works @@ -1737,8 +1734,8 @@ vos/Changes Changes made to port Perl to the VOS operating system vos/build.cm VOS command macro to build Perl vos/compile_perl.cm VOS command macro to build multiple version of Perl vos/config.alpha.def definitions used by config.pl -vos/config.ga.def definitions used by config.pl vos/config.alpha.h config.h for use with alpha VOS POSIX.1 support +vos/config.ga.def definitions used by config.pl vos/config.ga.h config.h for use with generally-available VOS POSIX.1 support vos/config.pl script to convert a config_h.SH to a config.h vos/configure_perl.cm VOS command macro to configure perl before building diff --git a/embed.h b/embed.h index 27b828c..70d4c36 100644 --- a/embed.h +++ b/embed.h @@ -1087,10 +1087,6 @@ # 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 @@ -2549,10 +2545,6 @@ # 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) @@ -4959,12 +4951,6 @@ #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 609b351..fa22c84 100755 --- a/embed.pl +++ b/embed.pl @@ -2467,10 +2467,6 @@ 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 3d0591c..5a3850c 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -2292,8 +2292,6 @@ #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 e6f7804..b6a9c7c 100644 --- a/op.c +++ b/op.c @@ -2249,11 +2249,13 @@ Perl_fold_constants(pTHX_ register OP *o) if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK && type != OP_NEGATE) { -#ifdef PERL_PRESERVE_IVUV - /* Only bother to attempt to fold to IV if - most operators will benefit */ - SvIV_please(sv); -#endif + IV iv = SvIV(sv); + if ((NV)iv == SvNV(sv)) { + SvREFCNT_dec(sv); + sv = newSViv(iv); + } + else + SvIOK_off(sv); /* undo SvIV() damage */ } return newSVOP(OP_CONST, 0, sv); } diff --git a/perl.h b/perl.h index 9c6883b..a55ebef 100644 --- a/perl.h +++ b/perl.h @@ -1084,11 +1084,6 @@ 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. @@ -3240,9 +3235,6 @@ typedef struct am_table_short AMTS; # if !defined(Strtol) && defined(HAS_STRTOLL) # define Strtol strtoll # endif -# if !defined(Strtol) && defined(HAS_STRTOQ) -# define Strtol strtoq -# endif /* is there atoq() anywhere? */ #endif #if !defined(Strtol) && defined(HAS_STRTOL) diff --git a/pod/perlapi.pod b/pod/perlapi.pod index ff01f97..be02ab4 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -298,7 +298,7 @@ L. SV* cv_const_sv(CV* cv) =for hackers -Found in file op.c +Found in file opmini.c =item dMARK @@ -1178,7 +1178,7 @@ eligible for inlining at compile-time. CV* newCONSTSUB(HV* stash, char* name, SV* sv) =for hackers -Found in file op.c +Found in file opmini.c =item newHV @@ -1324,7 +1324,7 @@ Found in file sv.c Used by C to hook up XSUBs as Perl subs. =for hackers -Found in file op.c +Found in file opmini.c =item newXSproto diff --git a/pp.c b/pp.c index 2cb463e..eaa4d17 100644 --- a/pp.c +++ b/pp.c @@ -925,114 +925,6 @@ 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 ); @@ -1224,146 +1116,11 @@ PP(pp_repeat) PP(pp_subtract) { - 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 + djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { - dPOPnv; - if (!useleft) { - /* left operand is undef, treat as zero - value */ - SETn(-value); - RETURN; - } - SETn( TOPn - value ); - RETURN; + dPOPTOPnnrl_ul; + SETn( left - right ); + RETURN; } } @@ -1404,74 +1161,6 @@ 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)); @@ -1482,74 +1171,6 @@ 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)); @@ -1560,74 +1181,6 @@ 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)); @@ -1638,74 +1191,6 @@ 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)); @@ -1716,66 +1201,6 @@ 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)); @@ -1786,84 +1211,6 @@ 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; @@ -2050,15 +1397,11 @@ PP(pp_negate) djSP; dTARGET; tryAMAGICun(neg); { dTOPss; - int flags = SvFLAGS(sv); if (SvGMAGICAL(sv)) mg_get(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 (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) { if (SvIsUV(sv)) { if (SvIVX(sv) == IV_MIN) { - /* 2s complement assumption. */ SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */ RETURN; } @@ -2071,12 +1414,6 @@ PP(pp_negate) SETi(-SvIVX(sv)); RETURN; } -#ifdef PERL_PRESERVE_IVUV - else { - SETu((UV)IV_MIN); - RETURN; - } -#endif } if (SvNIOKp(sv)) SETn(-SvNV(sv)); @@ -2095,12 +1432,8 @@ PP(pp_negate) sv_setpvn(TARG, "-", 1); sv_catsv(TARG, sv); } - else { - SvIV_please(sv); - if (SvIOK(sv)) - goto oops_its_an_int; - sv_setnv(TARG, -SvNV(sv)); - } + else + sv_setnv(TARG, -SvNV(sv)); SETTARG; } else @@ -2563,49 +1896,38 @@ PP(pp_int) { djSP; dTARGET; { - 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; + NV value = TOPn; + IV iv; + + if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) { + iv = SvIVX(TOPs); + SETi(iv); + } + else { 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 { - if (value > (NV)IV_MIN - 0.5) { - SETi(I_V(value)); - } else { + 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 - SETn(value); - } - } + } + iv = I_V(value); + if (iv == value) + SETi(iv); + else + SETn(value); } } RETURN; @@ -2615,30 +1937,18 @@ PP(pp_abs) { djSP; dTARGET; tryAMAGICun(abs); { - /* 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; + 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 { if (value < 0.0) - value = -value; + value = -value; SETn(value); } } diff --git a/pp_hot.c b/pp_hot.c index 6a5b96f..25a0032 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -279,69 +279,6 @@ 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)); @@ -360,7 +297,7 @@ PP(pp_preinc) ++SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } - else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */ + else sv_inc(TOPs); SvSETMAGIC(TOPs); return NORMAL; @@ -379,125 +316,11 @@ PP(pp_or) PP(pp_add) { - 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 + djSP; dATARGET; tryAMAGICbin(add,opASSIGN); { - dPOPnv; - if (!useleft) { - /* left operand is undef, treat as zero. + 0.0 is identity. */ - SETn(value); - RETURN; - } - SETn( value + TOPn ); - RETURN; + dPOPTOPnnrl_ul; + SETn( left + right ); + RETURN; } } diff --git a/proto.h b/proto.h index c9e42db..288a311 100644 --- a/proto.h +++ b/proto.h @@ -1207,10 +1207,6 @@ 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.h b/sv.h index 53fc1f0..39c1c29 100644 --- a/sv.h +++ b/sv.h @@ -448,9 +448,6 @@ 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. @@ -565,7 +562,6 @@ Set the length of the string which is in the SV. See C. #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) @@ -718,12 +714,6 @@ 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 288d3bd..a90574f 100644 --- a/t/lib/peek.t +++ b/t/lib/peek.t @@ -88,10 +88,10 @@ do_test( 5, do_test( 6, $c + $d, -'SV = IV\\($ADDR\\) at $ADDR +'SV = NV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(PADTMP,IOK,pIOK\\) - IV = 456'); + FLAGS = \\(PADTMP,NOK,pNOK\\) + NV = 456'); ($d = "789") += 0.1; @@ -110,8 +110,8 @@ do_test( 8, 0xabcd, 'SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(.*IOK,READONLY,pIOK\\) - IV = 43981'); + FLAGS = \\(.*IOK,READONLY,pIOK,IsUV\\) + UV = 43981'); do_test( 9, undef, @@ -154,10 +154,12 @@ do_test(11, FLAGS = \\(IOK,pIOK\\) IV = 123 Elt No. 1 - SV = IV\\($ADDR\\) at $ADDR + SV = PVNV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(IOK,pIOK\\) - IV = 456'); + FLAGS = \\(IOK,NOK,pIOK,pNOK\\) + IV = 456 + NV = 456 + PV = 0'); do_test(12, {$b=>$c}, @@ -178,10 +180,12 @@ do_test(12, RITER = -1 EITER = 0x0 Elt "123" HASH = $ADDR - SV = IV\\($ADDR\\) at $ADDR + SV = PVNV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(IOK,pIOK\\) - IV = 456'); + FLAGS = \\(IOK,NOK,pIOK,pNOK\\) + IV = 456 + NV = 456 + PV = 0'); do_test(13, sub(){@_}, diff --git a/t/op/cmp.t b/t/op/cmp.t index ffd34c6..4a7e68d 100755 --- a/t/op/cmp.t +++ b/t/op/cmp.t @@ -1,185 +1,35 @@ #!./perl -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); +@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1); -$expect = 6 * ($#FOO+2) * ($#FOO+1); +$expect = ($#FOO+2) * ($#FOO+1); print "1..$expect\n"; my $ok = 0; for my $i (0..$#FOO) { for my $j ($i..$#FOO) { $ok++; - # 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)) + 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]) { print "ok $ok\n"; } else { - print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, ne disagrees\n"; + print "not ok $ok ($FOO[$i] <=> $FOO[$j]) gives: '$cmp'\n"; } $ok++; - if ($cmp == -1 && !($i15 ge $j15) || - $cmp == 0 && ($i15 ge $j15) || - $cmp == 1 && ($i15 ge $j15)) + $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]) { print "ok $ok\n"; } else { - print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, ge disagrees\n"; + print "not ok $ok ($FOO[$i] cmp $FOO[$j]) gives '$cmp'\n"; } } } diff --git a/t/op/numconvert.t b/t/op/numconvert.t index 3db280b..f3c9867 100755 --- a/t/op/numconvert.t +++ b/t/op/numconvert.t @@ -85,15 +85,8 @@ 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"; @@ -185,18 +178,9 @@ for my $num_chain (1..$max_chain) { } push @ans, $inpt; } - 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++, - } - } + $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]; } print "not " if $nok; print "ok $test\n";