From: Nicholas Clark Date: Mon, 27 Mar 2006 21:04:58 +0000 (+0000) Subject: Merge the cut & paste code from Perl_call_sv/Perl_fold_constants with X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=edb2152a8435aa2e1308442c03e82c10e128574e;p=p5sagit%2Fp5-mst-13.2.git Merge the cut & paste code from Perl_call_sv/Perl_fold_constants with the near identical code in pp_entertry into Perl_create_eval_scope. Move the cut & paste code from Perl_call_sv/Perl_fold_constants into Perl_delete_eval_scope. p4raw-id: //depot/perl@27617 --- diff --git a/cop.h b/cop.h index ef92d8e..359a427 100644 --- a/cop.h +++ b/cop.h @@ -646,6 +646,8 @@ L. #define G_KEEPERR 16 /* Append errors to $@, don't overwrite it */ #define G_NODEBUG 32 /* Disable debugging at toplevel. */ #define G_METHOD 64 /* Calling method. */ +#define G_FAKINGEVAL 256 /* Faking en eval context for call_sv or + fold_constants. */ /* flag bits for PL_in_eval */ #define EVAL_NULL 0 /* not in an eval */ diff --git a/embed.fnc b/embed.fnc index a124e20..d74193e 100644 --- a/embed.fnc +++ b/embed.fnc @@ -129,6 +129,7 @@ ApR |UV |cast_uv |NV f ApR |I32 |my_chsize |int fd|Off_t length #endif pR |OP* |convert |I32 optype|I32 flags|NULLOK OP* o +pM |PERL_CONTEXT* |create_eval_scope|U32 flags : croak()'s first parm can be NULL. Otherwise, mod_perl breaks. Afprd |void |croak |NULLOK const char* pat|... Apr |void |vcroak |NN const char* pat|NULLOK va_list* args @@ -173,6 +174,7 @@ Ap |I32 |debstack Ap |I32 |debstackptrs Ap |char* |delimcpy |NN char* to|NN const char* toend|NN const char* from \ |NN const char* fromend|int delim|NN I32* retlen +pM |void |delete_eval_scope p |void |deprecate |NN const char* s p |void |deprecate_old |NN const char* s Afp |OP* |die |NULLOK const char* pat|... diff --git a/embed.h b/embed.h index 93dda39..d6b9bfa 100644 --- a/embed.h +++ b/embed.h @@ -94,6 +94,7 @@ #endif #ifdef PERL_CORE #define convert Perl_convert +#define create_eval_scope Perl_create_eval_scope #endif #define croak Perl_croak #define vcroak Perl_vcroak @@ -146,6 +147,7 @@ #define debstackptrs Perl_debstackptrs #define delimcpy Perl_delimcpy #ifdef PERL_CORE +#define delete_eval_scope Perl_delete_eval_scope #define deprecate Perl_deprecate #define deprecate_old Perl_deprecate_old #endif @@ -2272,6 +2274,7 @@ #endif #ifdef PERL_CORE #define convert(a,b,c) Perl_convert(aTHX_ a,b,c) +#define create_eval_scope(a) Perl_create_eval_scope(aTHX_ a) #endif #define vcroak(a,b) Perl_vcroak(aTHX_ a,b) #if defined(PERL_IMPLICIT_CONTEXT) @@ -2307,6 +2310,7 @@ #define debstackptrs() Perl_debstackptrs(aTHX) #define delimcpy(a,b,c,d,e,f) Perl_delimcpy(aTHX_ a,b,c,d,e,f) #ifdef PERL_CORE +#define delete_eval_scope() Perl_delete_eval_scope(aTHX) #define deprecate(a) Perl_deprecate(aTHX_ a) #define deprecate_old(a) Perl_deprecate_old(aTHX_ a) #endif diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t index dcd868f..9a69030 100644 --- a/ext/B/t/concise-xs.t +++ b/ext/B/t/concise-xs.t @@ -117,7 +117,7 @@ use Getopt::Std; use Carp; use Test::More tests => ( # per-pkg tests (function ct + require_ok) 40 + 16 # Data::Dumper, Digest::MD5 - + 511 + 234 # B::Deparse, B + + 511 + 235 # B::Deparse, B + 588 + 189 # POSIX, IO::Socket + 3 * ($] > 5.009) + 14 * ($] >= 5.009003) diff --git a/op.c b/op.c index 1fd94c2..ef05f5b 100644 --- a/op.c +++ b/op.c @@ -2183,22 +2183,8 @@ Perl_fold_constants(pTHX_ register OP *o) PL_op = curop; oldscope = PL_scopestack_ix; + create_eval_scope(G_FAKINGEVAL); - /* we're trying to emulate pp_entertry() here */ - { - register PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; - - ENTER; - SAVETMPS; - - PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); - PUSHEVAL(cx, 0, 0); - PL_eval_root = PL_op; /* Only needed so that goto works right. */ - - PL_in_eval = EVAL_INEVAL; - sv_setpvn(ERRSV,"",0); - } JMPENV_PUSH(ret); switch (ret) { @@ -2225,21 +2211,9 @@ Perl_fold_constants(pTHX_ register OP *o) } JMPENV_POP; - if (PL_scopestack_ix > oldscope) { - SV **newsp; - PMOP *newpm; - I32 gimme; - register PERL_CONTEXT *cx; - I32 optype; - - POPBLOCK(cx,newpm); - POPEVAL(cx); - PL_curpm = newpm; - LEAVE; - PERL_UNUSED_VAR(newsp); - PERL_UNUSED_VAR(gimme); - PERL_UNUSED_VAR(optype); - } + + if (PL_scopestack_ix > oldscope) + delete_eval_scope(); if (ret) goto nope; diff --git a/perl.c b/perl.c index a98314b..7e0f842 100644 --- a/perl.c +++ b/perl.c @@ -2604,27 +2604,11 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) else { myop.op_other = (OP*)&myop; PL_markstack_ptr--; - /* we're trying to emulate pp_entertry() here */ - { - register PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; - - ENTER; - SAVETMPS; - - PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); - PUSHEVAL(cx, 0, 0); - PL_eval_root = PL_op; /* Only needed so that goto works right. */ - - PL_in_eval = EVAL_INEVAL; - if (flags & G_KEEPERR) - PL_in_eval |= EVAL_KEEPERR; - else - sv_setpvn(ERRSV,"",0); - } + create_eval_scope(flags|G_FAKINGEVAL); PL_markstack_ptr++; JMPENV_PUSH(ret); + switch (ret) { case 0: redo_body: @@ -2661,21 +2645,8 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) break; } - if (PL_scopestack_ix > oldscope) { - SV **newsp; - PMOP *newpm; - I32 gimme; - register PERL_CONTEXT *cx; - I32 optype; - - POPBLOCK(cx,newpm); - POPEVAL(cx); - PL_curpm = newpm; - LEAVE; - PERL_UNUSED_VAR(newsp); - PERL_UNUSED_VAR(gimme); - PERL_UNUSED_VAR(optype); - } + if (PL_scopestack_ix > oldscope) + delete_eval_scope(); JMPENV_POP; } diff --git a/pp_ctl.c b/pp_ctl.c index 87a383d..c0e3a09 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -3562,22 +3562,57 @@ PP(pp_leaveeval) RETURNOP(retop); } -PP(pp_entertry) +/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it + close to the related Perl_create_eval_scope. */ +void +Perl_delete_eval_scope(pTHX) { - dVAR; dSP; + SV **newsp; + PMOP *newpm; + I32 gimme; register PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + I32 optype; + + POPBLOCK(cx,newpm); + POPEVAL(cx); + PL_curpm = newpm; + LEAVE; + PERL_UNUSED_VAR(newsp); + PERL_UNUSED_VAR(gimme); + PERL_UNUSED_VAR(optype); +} +/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was + also needed by Perl_fold_constants. */ +PERL_CONTEXT * +Perl_create_eval_scope(pTHX_ U32 flags) +{ + PERL_CONTEXT *cx; + const I32 gimme = GIMME_V; + ENTER; SAVETMPS; - PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP); + PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); PUSHEVAL(cx, 0, 0); - cx->blk_eval.retop = cLOGOP->op_other->op_next; + PL_eval_root = PL_op; /* Only needed so that goto works right. */ PL_in_eval = EVAL_INEVAL; - sv_setpvn(ERRSV,"",0); - PUTBACK; + if (flags & G_KEEPERR) + PL_in_eval |= EVAL_KEEPERR; + else + sv_setpvn(ERRSV,"",0); + if (flags & G_FAKINGEVAL) { + PL_eval_root = PL_op; /* Only needed so that goto works right. */ + } + return cx; +} + +PP(pp_entertry) +{ + dVAR; + PERL_CONTEXT *cx = create_eval_scope(0); + cx->blk_eval.retop = cLOGOP->op_other->op_next; return DOCATCH(PL_op->op_next); } diff --git a/proto.h b/proto.h index eb996cb..528bcf6 100644 --- a/proto.h +++ b/proto.h @@ -224,6 +224,7 @@ PERL_CALLCONV I32 Perl_my_chsize(pTHX_ int fd, Off_t length) PERL_CALLCONV OP* Perl_convert(pTHX_ I32 optype, I32 flags, OP* o) __attribute__warn_unused_result__; +PERL_CALLCONV PERL_CONTEXT* Perl_create_eval_scope(pTHX_ U32 flags); PERL_CALLCONV void Perl_croak(pTHX_ const char* pat, ...) __attribute__noreturn__ __attribute__format__(__printf__,pTHX_1,pTHX_2); @@ -373,6 +374,7 @@ PERL_CALLCONV char* Perl_delimcpy(pTHX_ char* to, const char* toend, const char* __attribute__nonnull__(pTHX_4) __attribute__nonnull__(pTHX_6); +PERL_CALLCONV void Perl_delete_eval_scope(pTHX); PERL_CALLCONV void Perl_deprecate(pTHX_ const char* s) __attribute__nonnull__(pTHX_1);