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
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
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
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)
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
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
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
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
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
# 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
# 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)
#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
# 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)
#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
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);
}
#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.
# 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)
SV* cv_const_sv(CV* cv)
=for hackers
-Found in file op.c
+Found in file opmini.c
=item dMARK
CV* newCONSTSUB(HV* stash, char* name, SV* sv)
=for hackers
-Found in file op.c
+Found in file opmini.c
=item newHV
Used by C<xsubpp> to hook up XSUBs as Perl subs.
=for hackers
-Found in file op.c
+Found in file opmini.c
=item newXSproto
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 );
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;
}
}
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));
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));
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));
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));
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));
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;
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;
}
SETi(-SvIVX(sv));
RETURN;
}
-#ifdef PERL_PRESERVE_IVUV
- else {
- SETu((UV)IV_MIN);
- RETURN;
- }
-#endif
}
if (SvNIOKp(sv))
SETn(-SvNV(sv));
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
{
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;
{
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);
}
}
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));
++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;
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;
}
}
# 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)
=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.
#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)
#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
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;
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,
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},
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(){@_},
#!./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";
}
}
}
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";
}
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";
projects / p5sagit/p5-mst-13.2.git / commitdiff