This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add :const anon sub attribute
authorFather Chrysostomos <sprout@cpan.org>
Mon, 19 Jan 2015 00:37:03 +0000 (16:37 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 20 Jan 2015 04:34:04 +0000 (20:34 -0800)
ext/Opcode/Opcode.pm
lib/B/Deparse.pm
lib/B/Op_private.pm
op.c
opcode.h
opnames.h
pod/perldiag.pod
pp.c
pp_proto.h
regen/opcodes
toke.c

index 94d3b21..b2a75d3 100644 (file)
@@ -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
index c496c8a..740192d 100644 (file)
@@ -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") {
index 32f8e20..9a48b96 100644 (file)
@@ -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]);
diff --git a/op.c b/op.c
index c1d4172..6ed08a3 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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 *
index 33e7e3d..5d910fd 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -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),
 
 };
 
index 1d259a1..013350a 100644 (file)
--- a/opnames.h
+++ b/opnames.h
@@ -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
index 650839c..cc46a85 100644 (file)
@@ -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
diff --git a/pp.c b/pp.c
index 8c66286..c4c4819 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -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
index 074f4ab..bbf6cf5 100644 (file)
@@ -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);
index f585cd2..3061d33 100644 (file)
@@ -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
diff --git a/toke.c b/toke.c
index dfb5b20..ffd6f90 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -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))