/* pp.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
}
else if (gimme == G_SCALAR) {
SV* sv = sv_newmortal();
+ if (SvRMAGICAL(TARG) && mg_find(TARG, PERL_MAGIC_tied))
+ Perl_croak(aTHX_ "Can't provide tied hash usage; "
+ "use keys(%%hash) to test if empty");
if (HvFILL((HV*)TARG))
Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
(long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
PP(pp_rv2sv)
{
+ GV *gv = Nullgv;
dSP; dTOPss;
if (SvROK(sv)) {
}
}
else {
- GV *gv = (GV*)sv;
char *sym;
STRLEN len;
+ gv = (GV*)sv;
if (SvTYPE(gv) != SVt_PVGV) {
if (SvGMAGICAL(sv)) {
sv = GvSV(gv);
}
if (PL_op->op_flags & OPf_MOD) {
- if (PL_op->op_private & OPpLVAL_INTRO)
- sv = save_scalar((GV*)TOPs);
+ if (PL_op->op_private & OPpLVAL_INTRO) {
+ if (cUNOP->op_first->op_type == OP_NULL)
+ sv = save_scalar((GV*)TOPs);
+ else if (gv)
+ sv = save_scalar(gv);
+ else
+ Perl_croak(aTHX_ PL_no_localize_ref);
+ }
else if (PL_op->op_private & OPpDEREF)
vivify_ref(sv, PL_op->op_private & OPpDEREF);
}
else
sv_inc(TOPs);
SvSETMAGIC(TOPs);
+ /* special case for undef: see thread at 2003-03/msg00536.html in archive */
if (!SvOK(TARG))
sv_setiv(TARG, 0);
SETs(TARG);
PP(pp_pow)
{
- dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
+ dSP; dATARGET;
+#ifdef PERL_PRESERVE_IVUV
+ bool is_int = 0;
+#endif
+ tryAMAGICbin(pow,opASSIGN);
#ifdef PERL_PRESERVE_IVUV
- /* ** is implemented with pow. pow is floating point. Perl programmers
- write 2 ** 31 and expect it to be 2147483648
- pow never made any guarantee to deliver a result to 53 (or whatever)
- bits of accuracy. Which is unfortunate, as perl programmers expect it
- to, and on some platforms (eg Irix with long doubles) it doesn't in
- a very visible case. (2 ** 31, which a regression test uses)
- So we'll implement power-of-2 ** +ve integer with multiplies, to avoid
- these problems. */
+ /* For integer to integer power, we do the calculation by hand wherever
+ we're sure it is safe; otherwise we call pow() and try to convert to
+ integer afterwards. */
{
SvIV_please(TOPm1s);
if (SvIOK(TOPm1s)) {
goto float_it; /* Can't do negative powers this way. */
}
}
- /* now we have integer ** positive integer.
- foo & (foo - 1) is zero only for a power of 2. */
+ /* now we have integer ** positive integer. */
+ is_int = 1;
+
+ /* foo & (foo - 1) is zero only for a power of 2. */
if (!(baseuv & (baseuv - 1))) {
- /* We are raising power-of-2 to postive integer.
+ /* We are raising power-of-2 to a positive integer.
The logic here will work for any base (even non-integer
bases) but it can be less accurate than
pow (base,power) or exp (power * log (base)) when the
NV base = baseuok ? baseuv : -(NV)baseuv;
int n = 0;
- /* The logic is this.
- x ** n === x ** m1 * x ** m2 where n = m1 + m2
- so as 42 is 32 + 8 + 2
- x ** 42 can be written as
- x ** 32 * x ** 8 * x ** 2
- I can calculate x ** 2, x ** 4, x ** 8 etc trivially:
- x ** 2n is x ** n * x ** n
- So I loop round, squaring x each time
- (x, x ** 2, x ** 4, x ** 8) and multiply the result
- by the x-value whenever that bit is set in the power.
- To finish as soon as possible I zero bits in the power
- when I've done them, so that power becomes zero when
- I clear the last bit (no more to do), and the loop
- terminates. */
for (; power; base *= base, n++) {
/* Do I look like I trust gcc with long longs here?
Do I hell. */
if (power & bit) {
result *= base;
/* Only bother to clear the bit if it is set. */
- power &= ~bit;
+ power -= bit;
/* Avoid squaring base again if we're done. */
if (power == 0) break;
}
}
SP--;
SETn( result );
+ SvIV_please(TOPs);
RETURN;
- }
- }
- }
+ } else {
+ register unsigned int highbit = 8 * sizeof(UV);
+ register unsigned int lowbit = 0;
+ register unsigned int diff;
+ while ((diff = (highbit - lowbit) >> 1)) {
+ if (baseuv & ~((1 << (lowbit + diff)) - 1))
+ lowbit += diff;
+ else
+ highbit -= diff;
+ }
+ /* we now have baseuv < 2 ** highbit */
+ if (power * highbit <= 8 * sizeof(UV)) {
+ /* result will definitely fit in UV, so use UV math
+ on same algorithm as above */
+ register UV result = 1;
+ register UV base = baseuv;
+ register int n = 0;
+ for (; power; base *= base, n++) {
+ register UV bit = (UV)1 << (UV)n;
+ if (power & bit) {
+ result *= base;
+ power -= bit;
+ if (power == 0) break;
+ }
+ }
+ SP--;
+ if (baseuok || !(power & 1))
+ /* answer is positive */
+ SETu( result );
+ else if (result <= (UV)IV_MAX)
+ /* answer negative, fits in IV */
+ SETi( -(IV)result );
+ else if (result == (UV)IV_MIN)
+ /* 2's complement assumption: special case IV_MIN */
+ SETi( IV_MIN );
+ else
+ /* answer negative, doesn't fit */
+ SETn( -(NV)result );
+ RETURN;
+ }
+ }
+ }
+ }
}
- float_it:
+ float_it:
#endif
{
- dPOPTOPnnrl;
- SETn( Perl_pow( left, right) );
- RETURN;
+ dPOPTOPnnrl;
+ SETn( Perl_pow( left, right) );
+#ifdef PERL_PRESERVE_IVUV
+ if (is_int)
+ SvIV_please(TOPs);
+#endif
+ RETURN;
}
}
}
RETURN;
} /* tried integer divide but it was not an integer result */
- } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
+ } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
} /* left wasn't SvIOK */
} /* right wasn't SvIOK */
#endif /* PERL_TRY_UV_DIVIDE */
}
}
+STATIC
+PP(pp_i_modulo_0)
+{
+ /* This is the vanilla old i_modulo. */
+ dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ {
+ dPOPTOPiirl;
+ if (!right)
+ DIE(aTHX_ "Illegal modulus zero");
+ SETi( left % right );
+ RETURN;
+ }
+}
+
+#if defined(__GLIBC__) && IVSIZE == 8
+STATIC
+PP(pp_i_modulo_1)
+{
+ /* This is the i_modulo with the workaround for the _moddi3 bug
+ * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
+ * See below for pp_i_modulo. */
+ dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ {
+ dPOPTOPiirl;
+ if (!right)
+ DIE(aTHX_ "Illegal modulus zero");
+ SETi( left % PERL_ABS(right) );
+ RETURN;
+ }
+}
+#endif
+
PP(pp_i_modulo)
{
- dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
- {
- dPOPTOPiirl;
- if (!right)
- DIE(aTHX_ "Illegal modulus zero");
- SETi( left % right );
- RETURN;
- }
+ dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ {
+ dPOPTOPiirl;
+ if (!right)
+ DIE(aTHX_ "Illegal modulus zero");
+ /* The assumption is to use hereafter the old vanilla version... */
+ PL_op->op_ppaddr =
+ PL_ppaddr[OP_I_MODULO] =
+ &Perl_pp_i_modulo_0;
+ /* .. but if we have glibc, we might have a buggy _moddi3
+ * (at least glicb 2.2.5 is known to have this bug), in other
+ * words our integer modulus with negative quad as the second
+ * argument might be broken. Test for this and re-patch the
+ * opcode dispatch table if that is the case, remembering to
+ * also apply the workaround so that this first round works
+ * right, too. See [perl #9402] for more information. */
+#if defined(__GLIBC__) && IVSIZE == 8
+ {
+ IV l = 3;
+ IV r = -10;
+ /* Cannot do this check with inlined IV constants since
+ * that seems to work correctly even with the buggy glibc. */
+ if (l % r == -3) {
+ /* Yikes, we have the bug.
+ * Patch in the workaround version. */
+ PL_op->op_ppaddr =
+ PL_ppaddr[OP_I_MODULO] =
+ &Perl_pp_i_modulo_1;
+ /* Make certain we work right this time, too. */
+ right = PERL_ABS(right);
+ }
+ }
+#endif
+ SETi( left % right );
+ RETURN;
+ }
}
PP(pp_i_add)
SETu(U_V(value));
} else {
#if defined(SPARC64_MODF_WORKAROUND)
- (void)sparc64_workaround_modf(value, &value);
-#else
-# if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
-# ifdef HAS_MODFL_POW32_BUG
+ (void)sparc64_workaround_modf(value, &value);
+#elif defined(HAS_MODFL_POW32_BUG)
/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
- {
- NV offset = Perl_modf(value, &value);
- (void)Perl_modf(offset, &offset);
- value += offset;
- }
-# else
- (void)Perl_modf(value, &value);
-# endif
-# else
- double tmp = (double)value;
- (void)Perl_modf(tmp, &tmp);
- value = (NV)tmp;
-# endif
+ NV offset = Perl_modf(value, &value);
+ (void)Perl_modf(offset, &offset);
+ value += offset;
+#else
+ (void)Perl_modf(value, &value);
#endif
SETn(value);
}
if (value > (NV)IV_MIN - 0.5) {
SETi(I_V(value));
} else {
-#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
-# ifdef HAS_MODFL_POW32_BUG
+#if defined(SPARC64_MODF_WORKAROUND)
+ (void)sparc64_workaround_modf(-value, &value);
+#elif defined(HAS_MODFL_POW32_BUG)
/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
- {
- NV offset = Perl_modf(-value, &value);
- (void)Perl_modf(offset, &offset);
- value += offset;
- }
-# else
- (void)Perl_modf(-value, &value);
-# endif
- value = -value;
+ NV offset = Perl_modf(-value, &value);
+ (void)Perl_modf(offset, &offset);
+ value += offset;
#else
- double tmp = (double)value;
- (void)Perl_modf(-tmp, &tmp);
- value = -(NV)tmp;
+ (void)Perl_modf(-value, &value);
#endif
- SETn(value);
+ SETn(-value);
}
}
}
tmps = SvPVX(TARG);
if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
- SvGROW(TARG,3);
+ SvGROW(TARG, 3);
+ tmps = SvPVX(TARG);
SvCUR_set(TARG, 2);
*tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
*tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
sv_utf8_downgrade(tsv, FALSE);
tmps = SvPVX(tsv);
}
+# ifdef USE_ITHREADS
+# ifdef HAS_CRYPT_R
+ if (!PL_reentrant_buffer->_crypt_struct_buffer) {
+ /* This should be threadsafe because in ithreads there is only
+ * one thread per interpreter. If this would not be true,
+ * we would need a mutex to protect this malloc. */
+ PL_reentrant_buffer->_crypt_struct_buffer =
+ (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
+#if defined(__GLIBC__) || defined(__EMX__)
+ if (PL_reentrant_buffer->_crypt_struct_buffer) {
+ PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
+ /* work around glibc-2.2.5 bug */
+ PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
+ }
+#endif
+ }
+# endif /* HAS_CRYPT_R */
+# endif /* USE_ITHREADS */
# ifdef FCRYPT
sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
# else
}
/* temporarily switch stacks */
SWITCHSTACK(PL_curstack, ary);
+ PL_curstackinfo->si_stack = ary;
make_mortal = 0;
}
}
}
}
s = rx->endp[0] + orig;
+ PUTBACK;
}
}
if (realarray) {
if (!mg) {
SWITCHSTACK(ary, oldstack);
+ PL_curstackinfo->si_stack = oldstack;
if (SvSMAGICAL(ary)) {
PUTBACK;
mg_set((SV*)ary);
if (gimme == G_ARRAY)
RETURN;
}
- if (iters || !pm->op_pmreplroot) {
- GETTARGET;
- PUSHi(iters);
- RETURN;
- }
- RETPUSHUNDEF;
+
+ GETTARGET;
+ PUSHi(iters);
+ RETURN;
}
PP(pp_lock)
projects / p5sagit/p5-mst-13.2.git / blobdiff