diff options
| -rw-r--r-- | dump.c | 2 | ||||
| -rw-r--r-- | ext/Errno/Errno_pm.PL | 3 | ||||
| -rw-r--r-- | intrpvar.h | 4 | ||||
| -rw-r--r-- | mg.c | 2 | ||||
| -rw-r--r-- | perl.c | 1 | ||||
| -rw-r--r-- | perl.h | 12 | ||||
| -rw-r--r-- | pod/perlapi.pod | 8 | ||||
| -rw-r--r-- | pp.c | 194 | ||||
| -rw-r--r-- | pp.h | 1 | ||||
| -rw-r--r-- | pp_hot.c | 196 | ||||
| -rw-r--r-- | sv.c | 21 | ||||
| -rwxr-xr-x | t/op/arith.t | 196 | ||||
| -rwxr-xr-x | t/op/each.t | 10 | ||||
| -rw-r--r-- | utf8.c | 18 | ||||
| -rw-r--r-- | utf8.h | 1 | ||||
| -rw-r--r-- | util.c | 17 | ||||
| -rw-r--r-- | vms/test.com | 3 |
17 files changed, 455 insertions, 234 deletions
@@ -823,6 +823,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (CvCONST(sv)) sv_catpv(d, "CONST,"); if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,"); if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); + if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,"); + if (CvMETHOD(sv)) sv_catpv(d, "METHOD,"); break; case SVt_PVHV: if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,"); diff --git a/ext/Errno/Errno_pm.PL b/ext/Errno/Errno_pm.PL index 3e34b90bee..dd165157f6 100644 --- a/ext/Errno/Errno_pm.PL +++ b/ext/Errno/Errno_pm.PL @@ -83,6 +83,9 @@ sub get_files { } elsif ($^O eq 'vmesa') { # OS/390 C compiler doesn't generate #file or #line directives $file{'../../vmesa/errno.h'} = 1; + } elsif ($Config{archname} eq 'epoc') { + # Watch out for cross compiling for EPOC (usually done on linux) + $file{'/usr/local/epoc/include/libc/sys/errno.h'} = 1; } elsif ($^O eq 'linux') { # Some Linuxes have weird errno.hs which generate # no #file or #line directives diff --git a/intrpvar.h b/intrpvar.h index 8b2aa29321..8ecd10ffed 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -362,8 +362,8 @@ PERLVARI(Inumeric_standard, bool, TRUE) /* Assume simple numerics */ PERLVARI(Inumeric_local, bool, TRUE) /* Assume local numerics */ -PERLVAR(Inumeric_radix, char) - /* The radix character if not '.' */ +PERLVAR(Inumeric_radix, SV *) + /* The radix separator if not '.' */ #endif /* !USE_LOCALE_NUMERIC */ @@ -2264,6 +2264,7 @@ Perl_sighandler(int sig) POPSTACK; if (SvTRUE(ERRSV)) { +#ifndef PERL_MICRO #ifdef HAS_SIGPROCMASK /* Handler "died", for example to get out of a restart-able read(). * Before we re-do that on its behalf re-enable the signal which was @@ -2278,6 +2279,7 @@ Perl_sighandler(int sig) (void)rsignal(sig, SIG_IGN); (void)rsignal(sig, &Perl_csighandler); #endif +#endif /* !PERL_MICRO */ Perl_die(aTHX_ Nullch); } cleanup: @@ -562,6 +562,7 @@ perl_destruct(pTHXx) #ifdef USE_LOCALE_NUMERIC Safefree(PL_numeric_name); PL_numeric_name = Nullch; + SvREFCNT_dec(PL_numeric_radix); #endif /* clear utf8 character classes */ @@ -3217,9 +3217,9 @@ typedef struct am_table_short AMTS; #define SET_NUMERIC_LOCAL() \ set_numeric_local(); -#define IS_NUMERIC_RADIX(c) \ +#define IS_NUMERIC_RADIX(s) \ ((PL_hints & HINT_LOCALE) && \ - PL_numeric_radix && (c) == PL_numeric_radix) + PL_numeric_radix && memEQ(s, SvPVX(PL_numeric_radix), SvCUR(PL_numeric_radix))) #define STORE_NUMERIC_LOCAL_SET_STANDARD() \ bool was_local = (PL_hints & HINT_LOCALE) && PL_numeric_local; \ @@ -3340,12 +3340,14 @@ typedef struct am_table_short AMTS; * massively. */ -#ifndef PERL_OLD_SIGNALS -#define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals() +#ifndef PERL_MICRO +# ifndef PERL_OLD_SIGNALS +# define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals() +# endif #endif #ifndef PERL_ASYNC_CHECK -#define PERL_ASYNC_CHECK() NOOP +# define PERL_ASYNC_CHECK() NOOP #endif /* diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 18e2c3dcba..aa50fbdf36 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -186,10 +186,10 @@ Found in file av.c Converts a string C<s> of length C<len> from UTF8 into byte encoding. Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to -the newly-created string, and updates C<len> to contain the new length. -Returns the original string if no conversion occurs, C<len> and -C<is_utf8> are unchanged. Do nothing if C<is_utf8> points to 0. Sets -C<is_utf8> to 0 if C<s> is converted or malformed . +the newly-created string, and updates C<len> to contain the new +length. Returns the original string if no conversion occurs, C<len> +is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to +0 if C<s> is converted or contains all 7bit characters. NOTE: this function is experimental and may change or be removed without notice. @@ -1242,134 +1242,106 @@ 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. */ + /* See comments in pp_add (in pp_hot.c) about Overflow, and how + "bad things" happen if you rely on signed integers wrapping. */ 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. */ + register UV auv; + bool auvok; + bool a_valid = 0; + 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; - } + auv = 0; + a_valid = auvok = 1; + /* left operand is undef, treat as zero. */ } 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; + if ((auvok = SvUOK(TOPm1s))) + auv = SvUVX(TOPm1s); + else { + register IV aiv = SvIVX(TOPm1s); + if (aiv >= 0) { + auv = aiv; + auvok = 1; /* Now acting as a sign flag. */ + } else { /* 2s complement assumption for IV_MIN */ + auv = (UV)-aiv; } - /* 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; + } + a_valid = 1; + } + } + if (a_valid) { + bool result_good = 0; + UV result; + register UV buv; + bool buvok = SvUOK(TOPs); + + if (buvok) + buv = SvUVX(TOPs); + else { + register IV biv = SvIVX(TOPs); + if (biv >= 0) { + buv = biv; + buvok = 1; + } else + buv = (UV)-biv; + } + /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, + else "IV" now, independant of how it came in. + if a, b represents positive, A, B negative, a maps to -A etc + a - b => (a - b) + A - b => -(a + b) + a - B => (a + b) + A - B => -(a - b) + all UV maths. negate result if A negative. + subtract if signs same, add if signs differ. */ + + if (auvok ^ buvok) { + /* Signs differ. */ + result = auv + buv; + if (result >= auv) + result_good = 1; + } else { + /* Signs same */ + if (auv >= buv) { + result = auv - buv; + /* Must get smaller */ + if (result <= auv) + result_good = 1; + } else { + result = buv - auv; + if (result <= buv) { + /* result really should be -(auv-buv). as its negation + of true value, need to swap our result flag */ + auvok = !auvok; + result_good = 1; } - } 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 */ } } + if (result_good) { + SP--; + if (auvok) + SETu( result ); + else { + /* Negate result */ + if (result <= (UV)IV_MIN) + SETi( -(IV)result ); + else { + /* result valid, but out of range for IV. */ + SETn( -(NV)result ); + } + } + RETURN; + } /* Overflow, drop through to NVs. */ } } #endif + useleft = USE_LEFT(TOPm1s); { dPOPnv; if (!useleft) { @@ -133,6 +133,7 @@ Pops a long off the stack. #define TOPs (*sp) #define TOPm1s (*(sp-1)) +#define TOPp1s (*(sp+1)) #define TOPp (SvPV(TOPs, PL_na)) /* deprecated */ #define TOPpx (SvPV(TOPs, n_a)) #define TOPn (SvNV(TOPs)) @@ -344,99 +344,137 @@ PP(pp_add) 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. */ + fp maths for integer values. + + How to detect overflow? + + C 99 section 6.2.6.1 says + + The range of nonnegative values of a signed integer type is a subrange + of the corresponding unsigned integer type, and the representation of + the same value in each type is the same. A computation involving + unsigned operands can never overflow, because a result that cannot be + represented by the resulting unsigned integer type is reduced modulo + the number that is one greater than the largest value that can be + represented by the resulting type. + + (the 9th paragraph) + + which I read as "unsigned ints wrap." + + signed integer overflow seems to be classed as "exception condition" + + If an exceptional condition occurs during the evaluation of an + expression (that is, if the result is not mathematically defined or not + in the range of representable values for its type), the behavior is + undefined. + + (6.5, the 5th paragraph) + + I had assumed that on 2s complement machines signed arithmetic would + wrap, hence coded pp_add and pp_subtract on the assumption that + everything perl builds on would be happy. After much wailing and + gnashing of teeth it would seem that irix64 knows its ANSI spec well, + knows that it doesn't need to, and doesn't. Bah. Anyway, the all- + unsigned code below is actually shorter than the old code. :-) + */ + 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. */ + register UV auv; + bool auvok; + bool a_valid = 0; + 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; + auv = 0; + a_valid = auvok = 1; + /* left operand is undef, treat as zero. + 0 is identity, + Could SETi or SETu right now, but space optimise by not adding + lots of code to speed up what is probably a rarish case. */ + } else { + /* Left operand is defined, so is it IV? */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + if ((auvok = SvUOK(TOPm1s))) + auv = SvUVX(TOPm1s); + else { + register IV aiv = SvIVX(TOPm1s); + if (aiv >= 0) { + auv = aiv; + auvok = 1; /* Now acting as a sign flag. */ + } else { /* 2s complement assumption for IV_MIN */ + auv = (UV)-aiv; + } + } + a_valid = 1; } } - /* Left operand is defined, so is it IV? */ - SvIV_please(TOPm1s); - if (SvIOK(TOPm1s)) { - bool auvok = SvUOK(TOPm1s); + if (a_valid) { + bool result_good = 0; + UV result; + register UV buv; 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; + + if (buvok) + buv = SvUVX(TOPs); + else { + register IV biv = SvIVX(TOPs); + if (biv >= 0) { + buv = biv; + buvok = 1; + } else + buv = (UV)-biv; + } + /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, + else "IV" now, independant of how it came in. + if a, b represents positive, A, B negative, a maps to -A etc + a + b => (a + b) + A + b => -(a - b) + a + B => (a - b) + A + B => -(a + b) + all UV maths. negate result if A negative. + add if signs same, subtract if signs differ. */ + + if (auvok ^ buvok) { + /* Signs differ. */ + if (auv >= buv) { + result = auv - buv; + /* Must get smaller */ + if (result <= auv) + result_good = 1; + } else { + result = buv - auv; + if (result <= buv) { + /* result really should be -(auv-buv). as its negation + of true value, need to swap our result flag */ + auvok = !auvok; + result_good = 1; } } - /* 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--; + } else { + /* Signs same */ + result = auv + buv; + if (result >= auv) + result_good = 1; + } + if (result_good) { + SP--; + if (auvok) 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; + else { + /* Negate result */ + if (result <= (UV)IV_MIN) + SETi( -(IV)result ); + else { + /* result valid, but out of range for IV. */ + SETn( -(NV)result ); } } - } /* end of IV+IV / UV+UV / mixed */ + RETURN; + } /* Overflow, drop through to NVs. */ } } #endif @@ -2448,6 +2448,9 @@ Perl_looks_like_number(pTHX_ SV *sv) I32 numtype = 0; I32 sawinf = 0; STRLEN len; +#ifdef USE_LOCALE_NUMERIC + bool specialradix = FALSE; +#endif if (SvPOK(sv)) { sbegin = SvPVX(sv); @@ -2514,10 +2517,15 @@ Perl_looks_like_number(pTHX_ SV *sv) if (*s == '.' #ifdef USE_LOCALE_NUMERIC - || IS_NUMERIC_RADIX(*s) + || (specialradix = IS_NUMERIC_RADIX(s)) #endif ) { - s++; +#ifdef USE_LOCALE_NUMERIC + if (specialradix) + s += SvCUR(PL_numeric_radix); + else +#endif + s++; numtype |= IS_NUMBER_NOT_INT; while (isDIGIT(*s)) /* optional digits after the radix */ s++; @@ -2525,10 +2533,15 @@ Perl_looks_like_number(pTHX_ SV *sv) } else if (*s == '.' #ifdef USE_LOCALE_NUMERIC - || IS_NUMERIC_RADIX(*s) + || (specialradix = IS_NUMERIC_RADIX(s)) #endif ) { - s++; +#ifdef USE_LOCALE_NUMERIC + if (specialradix) + s += SvCUR(PL_numeric_radix); + else +#endif + s++; 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)) { diff --git a/t/op/arith.t b/t/op/arith.t index 5b04f9365f..2847acb05f 100755 --- a/t/op/arith.t +++ b/t/op/arith.t @@ -1,15 +1,22 @@ -#!./perl +#!./perl -w -print "1..12\n"; +print "1..109\n"; sub try ($$) { print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; } +sub tryeq ($$$) { + if ($_[1] == $_[2]) { + print "ok $_[0]\n"; + } else { + print "not ok $_[0] # $_[1] != $_[2]\n"; + } +} -try 1, 13 % 4 == 1; -try 2, -13 % 4 == 3; -try 3, 13 % -4 == -3; -try 4, -13 % -4 == -1; +tryeq 1, 13 % 4, 1; +tryeq 2, -13 % 4, 3; +tryeq 3, 13 % -4, -3; +tryeq 4, -13 % -4, -1; my $limit = 1e6; @@ -24,7 +31,176 @@ try 8, abs(-13e21 % -4e21 - -1e21) < $limit; # UVs should behave properly -try 9, 4063328477 % 65535 == 27407; -try 10, 4063328477 % 4063328476 == 1; -try 11, 4063328477 % 2031664238 == 1; -try 12, 2031664238 % 4063328477 == 2031664238; +tryeq 9, 4063328477 % 65535, 27407; +tryeq 10, 4063328477 % 4063328476, 1; +tryeq 11, 4063328477 % 2031664238, 1; +tryeq 12, 2031664238 % 4063328477, 2031664238; + +# These should trigger wrapping on 32 bit IVs and UVs + +tryeq 13, 2147483647 + 0, 2147483647; + +# IV + IV promote to UV +tryeq 14, 2147483647 + 1, 2147483648; +tryeq 15, 2147483640 + 10, 2147483650; +tryeq 16, 2147483647 + 2147483647, 4294967294; +# IV + UV promote to NV +tryeq 17, 2147483647 + 2147483649, 4294967296; +# UV + IV promote to NV +tryeq 18, 4294967294 + 2, 4294967296; +# UV + UV promote to NV +tryeq 19, 4294967295 + 4294967295, 8589934590; + +# UV + IV to IV +tryeq 20, 2147483648 + -1, 2147483647; +tryeq 21, 2147483650 + -10, 2147483640; +# IV + UV to IV +tryeq 22, -1 + 2147483648, 2147483647; +tryeq 23, -10 + 4294967294, 4294967284; +# IV + IV to NV +tryeq 24, -2147483648 + -2147483648, -4294967296; +tryeq 25, -2147483640 + -10, -2147483650; + +# Hmm. Don't forget the simple stuff +tryeq 26, 1 + 1, 2; +tryeq 27, 4 + -2, 2; +tryeq 28, -10 + 100, 90; +tryeq 29, -7 + -9, -16; +tryeq 30, -63 + +2, -61; +tryeq 31, 4 + -1, 3; +tryeq 32, -1 + 1, 0; +tryeq 33, +29 + -29, 0; +tryeq 34, -1 + 4, 3; +tryeq 35, +4 + -17, -13; + +# subtraction +tryeq 36, 3 - 1, 2; +tryeq 37, 3 - 15, -12; +tryeq 38, 3 - -7, 10; +tryeq 39, -156 - 5, -161; +tryeq 40, -156 - -5, -151; +tryeq 41, -5 - -12, 7; +tryeq 42, -3 - -3, 0; +tryeq 43, 15 - 15, 0; + +tryeq 44, 2147483647 - 0, 2147483647; +tryeq 45, 2147483648 - 0, 2147483648; +tryeq 46, -2147483648 - 0, -2147483648; + +tryeq 47, 0 - -2147483647, 2147483647; +tryeq 48, -1 - -2147483648, 2147483647; +tryeq 49, 2 - -2147483648, 2147483650; + +tryeq 50, 4294967294 - 3, 4294967291; +tryeq 51, -2147483648 - -1, -2147483647; + +# IV - IV promote to UV +tryeq 52, 2147483647 - -1, 2147483648; +tryeq 53, 2147483647 - -2147483648, 4294967295; +# UV - IV promote to NV +tryeq 54, 4294967294 - -3, 4294967297; +# IV - IV promote to NV +tryeq 55, -2147483648 - +1, -2147483649; +# UV - UV promote to IV +tryeq 56, 2147483648 - 2147483650, -2; +# IV - UV promote to IV +tryeq 57, 2000000000 - 4000000000, -2000000000; + +# No warnings should appear; +my $a; +$a += 1; +tryeq 58, $a, 1; +undef $a; +$a += -1; +tryeq 59, $a, -1; +undef $a; +$a += 4294967290; +tryeq 60, $a, 4294967290; +undef $a; +$a += -4294967290; +tryeq 61, $a, -4294967290; +undef $a; +$a += 4294967297; +tryeq 62, $a, 4294967297; +undef $a; +$a += -4294967297; +tryeq 63, $a, -4294967297; + +my $s; +$s -= 1; +tryeq 64, $s, -1; +undef $s; +$s -= -1; +tryeq 65, $s, +1; +undef $s; +$s -= -4294967290; +tryeq 66, $s, +4294967290; +undef $s; +$s -= 4294967290; +tryeq 67, $s, -4294967290; +undef $s; +$s -= 4294967297; +tryeq 68, $s, -4294967297; +undef $s; +$s -= -4294967297; +tryeq 69, $s, +4294967297; + +# Multiplication + +tryeq 70, 1 * 3, 3; +tryeq 71, -2 * 3, -6; +tryeq 72, 3 * -3, -9; +tryeq 73, -4 * -3, 12; + +# check with 0xFFFF and 0xFFFF +tryeq 74, 65535 * 65535, 4294836225; +tryeq 75, 65535 * -65535, -4294836225; +tryeq 76, -65535 * 65535, -4294836225; +tryeq 77, -65535 * -65535, 4294836225; + +# check with 0xFFFF and 0x10001 +tryeq 78, 65535 * 65537, 4294967295; +tryeq 79, 65535 * -65537, -4294967295; +tryeq 80, -65535 * 65537, -4294967295; +tryeq 81, -65535 * -65537, 4294967295; + +# check with 0x10001 and 0xFFFF +tryeq 82, 65537 * 65535, 4294967295; +tryeq 83, 65537 * -65535, -4294967295; +tryeq 84, -65537 * 65535, -4294967295; +tryeq 85, -65537 * -65535, 4294967295; + +# These should all be dones as NVs +tryeq 86, 65537 * 65537, 4295098369; +tryeq 87, 65537 * -65537, -4295098369; +tryeq 88, -65537 * 65537, -4295098369; +tryeq 89, -65537 * -65537, 4295098369; + +# will overflow an IV (in 32-bit) +tryeq 90, 46340 * 46342, 0x80001218; +tryeq 91, 46340 * -46342, -0x80001218; +tryeq 92, -46340 * 46342, -0x80001218; +tryeq 93, -46340 * -46342, 0x80001218; + +tryeq 94, 46342 * 46340, 0x80001218; +tryeq 95, 46342 * -46340, -0x80001218; +tryeq 96, -46342 * 46340, -0x80001218; +tryeq 97, -46342 * -46340, 0x80001218; + +# will overflow a positive IV (in 32-bit) +tryeq 98, 65536 * 32768, 0x80000000; +tryeq 99, 65536 * -32768, -0x80000000; +tryeq 100, -65536 * 32768, -0x80000000; +tryeq 101, -65536 * -32768, 0x80000000; + +tryeq 102, 32768 * 65536, 0x80000000; +tryeq 103, 32768 * -65536, -0x80000000; +tryeq 104, -32768 * 65536, -0x80000000; +tryeq 105, -32768 * -65536, 0x80000000; + +# 2147483647 is prime. bah. + +tryeq 106, 46339 * 46341, 0x7ffea80f; +tryeq 107, 46339 * -46341, -0x7ffea80f; +tryeq 108, -46339 * 46341, -0x7ffea80f; +tryeq 109, -46339 * -46341, 0x7ffea80f; diff --git a/t/op/each.t b/t/op/each.t index f1012c6402..397176a40d 100755 --- a/t/op/each.t +++ b/t/op/each.t @@ -6,7 +6,7 @@ BEGIN { push @INC, '../lib'; } -print "1..25\n"; +print "1..26\n"; $h{'abc'} = 'ABC'; $h{'def'} = 'DEF'; @@ -163,9 +163,15 @@ print "ok 23\n"; print "#$u{$_}\n" for keys %u; # Used to core dump before change #8056. print "ok 24\n"; -%u = (qu"\xe3\x81\x82" => "downglade"); +$d = qu"\xe3\x81\x82"; +%u = ($d => "downgrade"); for (keys %u) { use bytes; print "not " if length ne 3 or $_ ne "\xe3\x81\x82"; print "ok 25\n"; } +{ + use bytes; + print "not " if length($d) ne 6 or $d ne qu"\xe3\x81\x82"; + print "ok 26\n"; +} @@ -587,10 +587,10 @@ Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len) Converts a string C<s> of length C<len> from UTF8 into byte encoding. Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to -the newly-created string, and updates C<len> to contain the new length. -Returns the original string if no conversion occurs, C<len> and -C<is_utf8> are unchanged. Do nothing if C<is_utf8> points to 0. Sets -C<is_utf8> to 0 if C<s> is converted or malformed . +the newly-created string, and updates C<len> to contain the new +length. Returns the original string if no conversion occurs, C<len> +is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to +0 if C<s> is converted or contains all 7bit characters. =cut */ @@ -605,16 +605,12 @@ Perl_bytes_from_utf8(pTHX_ U8* s, STRLEN *len, bool *is_utf8) if (!*is_utf8) return start; - /* ensure valid UTF8 and chars < 256 before updating string */ + /* ensure valid UTF8 and chars < 256 before converting string */ for (send = s + *len; s < send;) { U8 c = *s++; if (!UTF8_IS_ASCII(c)) { if (UTF8_IS_CONTINUATION(c) || s >= send || - !UTF8_IS_CONTINUATION(*s)) { - *is_utf8 = 0; - return start; - } - if ((c & 0xfc) != 0xc0) + !UTF8_IS_CONTINUATION(*s) || UTF8_IS_DOWNGRADEABLE_START(c)) return start; s++, count++; } @@ -626,7 +622,7 @@ Perl_bytes_from_utf8(pTHX_ U8* s, STRLEN *len, bool *is_utf8) return start; Newz(801, d, (*len) - count + 1, U8); - d = s = start; + s = start; start = d; while (s < send) { U8 c = *s++; if (UTF8_IS_ASCII(c)) @@ -68,6 +68,7 @@ END_EXTERN_C #define UTF8_IS_START(c) (((U8)c) >= 0xc0 && (((U8)c) <= 0xfd)) #define UTF8_IS_CONTINUATION(c) (((U8)c) >= 0x80 && (((U8)c) <= 0xbf)) #define UTF8_IS_CONTINUED(c) (((U8)c) & 0x80) +#define UTF8_IS_DOWNGRADEABLE_START(c) (((U8)c & 0xfc) != 0xc0) #define UTF8_CONTINUATION_MASK ((U8)0x3f) #define UTF8_ACCUMULATION_SHIFT 6 @@ -575,11 +575,18 @@ Perl_set_numeric_radix(pTHX) struct lconv* lc; lc = localeconv(); - if (lc && lc->decimal_point) - /* We assume that decimal separator aka the radix - * character is always a single character. If it - * ever is a string, this needs to be rethunk. */ - PL_numeric_radix = *lc->decimal_point; + if (lc && lc->decimal_point) { + if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) { + SvREFCNT_dec(PL_numeric_radix); + PL_numeric_radix = 0; + } + else { + if (PL_numeric_radix) + sv_setpv(PL_numeric_radix, lc->decimal_point); + else + PL_numeric_radix = newSVpv(lc->decimal_point, 0); + } + } else PL_numeric_radix = 0; # endif /* HAS_LOCALECONV */ diff --git a/vms/test.com b/vms/test.com index 8b93f5b28d..6fae18dba5 100644 --- a/vms/test.com +++ b/vms/test.com @@ -98,7 +98,8 @@ $ $! And do it $ Show Process/Accounting $ testdir = "Directory/NoHead/NoTrail/Column=1" -$ Define 'dbg'Perlshr Sys$Disk:[-]'dbg'PerlShr'exe' +$ PerlShr_filespec = f$parse("Sys$Disk:[-]''dbg'PerlShr''exe'") +$ Define 'dbg'Perlshr 'PerlShr_filespec' $ MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p3'" "''p4'" "''p5'" "''p6'" $ Deck/Dollar=$$END-OF-TEST$$ # $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $ |