diff options
| -rw-r--r-- | ext/Opcode/Opcode.pm | 2 | ||||
| -rw-r--r-- | lib/B/Deparse.pm | 8 | ||||
| -rw-r--r-- | lib/B/Op_private.pm | 1 | ||||
| -rw-r--r-- | op.c | 11 | ||||
| -rw-r--r-- | opcode.h | 9 | ||||
| -rw-r--r-- | opnames.h | 3 | ||||
| -rw-r--r-- | pod/perldiag.pod | 6 | ||||
| -rw-r--r-- | pp.c | 11 | ||||
| -rw-r--r-- | pp_proto.h | 1 | ||||
| -rw-r--r-- | regen/opcodes | 1 | ||||
| -rw-r--r-- | toke.c | 11 |
11 files changed, 56 insertions, 8 deletions
diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index 94d3b219be..b2a75d3970 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -337,7 +337,7 @@ invert_opset function. warn die lineseq nextstate scope enter leave - rv2cv anoncode prototype coreargs + rv2cv anoncode prototype coreargs anonconst entersub leavesub leavesublv return method method_named method_super method_redir method_redir_super diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index c496c8ae88..740192dfb5 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -58,7 +58,7 @@ BEGIN { # be to fake up a dummy constant that will never actually be true. foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE - RXf_PMf_CHARSET RXf_PMf_KEEPCOPY + RXf_PMf_CHARSET RXf_PMf_KEEPCOPY CVf_ANONCONST CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV @@ -1213,11 +1213,12 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); if ($cv->FLAGS & SVf_POK) { $proto = "(". $cv->PV . ") "; } - if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) { + if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) { $proto .= ": "; $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE; $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED; $proto .= "method " if $cv->CvFLAGS & CVf_METHOD; + $proto .= "const " if $cv->CvFLAGS & CVf_ANONCONST; } local($self->{'curcv'}) = $cv; @@ -2587,6 +2588,9 @@ sub pp_refgen { my $kid = $op->first; if ($kid->name eq "null") { my $anoncode = $kid = $kid->first; + if ($anoncode->name eq "anonconst") { + $anoncode = $anoncode->first->first->sibling; + } if ($anoncode->name eq "anoncode" or !null($anoncode = $kid->sibling) and $anoncode->name eq "anoncode") { diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm index 32f8e20e6b..9a48b96036 100644 --- a/lib/B/Op_private.pm +++ b/lib/B/Op_private.pm @@ -240,6 +240,7 @@ $bits{akeys}{0} = $bf[0]; $bits{alarm}{0} = $bf[0]; $bits{and}{0} = $bf[0]; $bits{andassign}{0} = $bf[0]; +$bits{anonconst}{0} = $bf[0]; @{$bits{anonhash}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); @{$bits{anonlist}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); @{$bits{atan2}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); @@ -9274,9 +9274,16 @@ Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block) OP * Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) { - return newUNOP(OP_REFGEN, 0, + SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)); + OP * anoncode = newSVOP(OP_ANONCODE, 0, - MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)))); + cv); + if (CvANONCONST(cv)) + anoncode = newUNOP(OP_ANONCONST, 0, + op_convert_list(OP_ENTERSUB, + OPf_STACKED|OPf_WANT_SCALAR, + anoncode)); + return newUNOP(OP_REFGEN, 0, anoncode); } OP * @@ -535,6 +535,7 @@ EXTCONST char* const PL_op_name[] = { "lvref", "lvrefslice", "lvavref", + "anonconst", "freed", }; #endif @@ -930,6 +931,7 @@ EXTCONST char* const PL_op_desc[] = { "lvalue ref assignment", "lvalue ref assignment", "lvalue array reference", + "anonymous constant", "freed op", }; #endif @@ -1339,6 +1341,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ Perl_pp_lvref, Perl_pp_lvrefslice, Perl_pp_lvavref, + Perl_pp_anonconst, } #endif #ifdef PERL_PPADDR_INITED @@ -1744,6 +1747,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ Perl_ck_null, /* lvref */ Perl_ck_null, /* lvrefslice */ Perl_ck_null, /* lvavref */ + Perl_ck_null, /* anonconst */ } #endif #ifdef PERL_CHECK_INITED @@ -2143,6 +2147,7 @@ EXTCONST U32 PL_opargs[] = { 0x00000b40, /* lvref */ 0x00000440, /* lvrefslice */ 0x00000b40, /* lvavref */ + 0x00000144, /* anonconst */ }; #endif @@ -2772,6 +2777,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 200, /* lvref */ 206, /* lvrefslice */ 207, /* lvavref */ + 0, /* anonconst */ }; @@ -2790,7 +2796,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { */ EXTCONST U16 PL_op_private_bitdefs[] = { - 0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, ucfirst, lcfirst, uc, lc, quotemeta, aeach, akeys, avalues, each, values, pop, shift, range, and, or, dor, andassign, orassign, dorassign, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, reach, rvalues, fc */ + 0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, ucfirst, lcfirst, uc, lc, quotemeta, aeach, akeys, avalues, each, values, pop, shift, range, and, or, dor, andassign, orassign, dorassign, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, reach, rvalues, fc, anonconst */ 0x29dc, 0x3bd9, /* pushmark */ 0x00bd, /* wantarray, runcv */ 0x03b8, 0x1570, 0x3c8c, 0x3748, 0x2da5, /* const */ @@ -3250,6 +3256,7 @@ EXTCONST U8 PL_op_private_valid[] = { /* LVREF */ (OPpARG1_MASK|OPpLVREF_ELEM|OPpLVREF_ITER|OPpLVREF_TYPE|OPpPAD_STATE|OPpLVAL_INTRO), /* LVREFSLICE */ (OPpLVAL_INTRO), /* LVAVREF */ (OPpARG1_MASK|OPpPAD_STATE|OPpLVAL_INTRO), + /* ANONCONST */ (OPpARG1_MASK), }; @@ -401,10 +401,11 @@ typedef enum opcode { OP_LVREF = 384, OP_LVREFSLICE = 385, OP_LVAVREF = 386, + OP_ANONCONST = 387, OP_max } opcode; -#define MAXO 387 +#define MAXO 388 #define OP_FREED MAXO /* the OP_IS_* macros are optimized to a simple range check because diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 650839c1fc..cc46a85d27 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -1699,6 +1699,12 @@ to define an overloaded constant, or when trying to find the character name specified in the C<\N{...}> escape. Perhaps you forgot to load the corresponding L<overload> pragma?. +=item :const is not permitted on named subroutines + +(F) The "const" attribute causes an anonymous subroutine to be run and +its value captured at the time that it is cloned. Names subroutines are +not cloned like this, so the attribute does not make sense on them. + =item Copy method did not return a reference (F) The method which overloads "=" is buggy. See @@ -6376,6 +6376,17 @@ PP(pp_lvavref) } } +PP(pp_anonconst) +{ + dSP; + dTOPss; + SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV + ? CopSTASH(PL_curcop) + : NULL, + NULL, SvREFCNT_inc_simple_NN(sv)))); + RETURN; +} + /* * Local variables: * c-indentation-style: bsd diff --git a/pp_proto.h b/pp_proto.h index 074f4ab8a3..bbf6cf5f76 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -16,6 +16,7 @@ PERL_CALLCONV OP *Perl_pp_akeys(pTHX); PERL_CALLCONV OP *Perl_pp_alarm(pTHX); PERL_CALLCONV OP *Perl_pp_and(pTHX); PERL_CALLCONV OP *Perl_pp_anoncode(pTHX); +PERL_CALLCONV OP *Perl_pp_anonconst(pTHX); PERL_CALLCONV OP *Perl_pp_anonhash(pTHX); PERL_CALLCONV OP *Perl_pp_anonlist(pTHX); PERL_CALLCONV OP *Perl_pp_aslice(pTHX); diff --git a/regen/opcodes b/regen/opcodes index f585cd2727..3061d33efb 100644 --- a/regen/opcodes +++ b/regen/opcodes @@ -565,3 +565,4 @@ refassign lvalue ref assignment ck_refassign ds2 lvref lvalue ref assignment ck_null d% lvrefslice lvalue ref assignment ck_null d@ lvavref lvalue array reference ck_null d% +anonconst anonymous constant ck_null ds1 @@ -5366,6 +5366,15 @@ Perl_yylex(pTHX) sv_free(sv); CvMETHOD_on(PL_compcv); } + else if (!PL_in_my && len == 5 + && strnEQ(SvPVX(sv), "const", len)) + { + sv_free(sv); + CvANONCONST_on(PL_compcv); + if (!CvANON(PL_compcv)) + yyerror(":const is not permitted on named " + "subroutines"); + } /* After we've set the flags, it could be argued that we don't need to do the attributes.pm-based setting process, and shouldn't bother appending recognized @@ -10591,7 +10600,7 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) CvFLAGS(PL_compcv) |= flags; PL_subline = CopLINE(PL_curcop); - CvPADLIST_set(PL_compcv, pad_new(padnew_SAVE|padnew_SAVESUB)); + CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB); CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv)); CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; if (outsidecv && CvPADLIST(outsidecv)) |