In perl.git, the branch sprout/lvref has been updated <http://perl5.git.perl.org/perl.git/commitdiff/b736d9f32b4ead3c69d9f30942f11d6d8984bf94?hp=8af6ccfbe23c86b54f50b3c76eb941eaf8cb74aa>
- Log ----------------------------------------------------------------- commit b736d9f32b4ead3c69d9f30942f11d6d8984bf94 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 26 10:40:19 2014 -0700 \@array[@slice] assignment plus changes to the aelem tests to check rhs context. I did \local @a[@s] at the same time, since I was practically copying and pasting code from aelem (ok, not quite). M op.c M pp.c M t/op/lvref.t commit da9de61a27dbc5ba16c2c7e567bf5b2bc5b75296 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 25 22:13:33 2014 -0700 pp.c: Dodge compiler warning M pp.c commit e5a212c3e723b7f13f07a950a343425520f8abb5 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 25 22:10:39 2014 -0700 lvrefslice gets OPpLVAL_INTRO M lib/B/Op_private.pm M opcode.h M regen/op_private commit d74896ae33d10830875a41983c12b5015c3ff508 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 25 22:08:15 2014 -0700 Add lvrefslice op type M ext/Opcode/Opcode.pm M opcode.h M opnames.h M pp.c M pp_proto.h M regen/opcodes ----------------------------------------------------------------------- Summary of changes: ext/Opcode/Opcode.pm | 2 +- lib/B/Op_private.pm | 2 +- op.c | 5 +++++ opcode.h | 8 ++++++++ opnames.h | 3 ++- pp.c | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++- pp_proto.h | 1 + regen/op_private | 2 +- regen/opcodes | 1 + t/op/lvref.t | 25 ++++++++++++++++++++----- 10 files changed, 92 insertions(+), 10 deletions(-) diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index 9195bca..0fb06ed 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -402,7 +402,7 @@ These are a hotchpotch of opcodes still waiting to be considered once - rv2gv refgen srefgen ref sbind lvref + rv2gv refgen srefgen ref sbind lvref lvrefslice bless -- could be used to change ownership of objects (reblessing) diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm index 7ae853d..4f4ef57 100644 --- a/lib/B/Op_private.pm +++ b/lib/B/Op_private.pm @@ -128,7 +128,7 @@ $bits{$_}{5} = 'OPpHUSH_VMSISH' for qw(dbstate nextstate); $bits{$_}{2} = 'OPpITER_REVERSED' for qw(enteriter iter); $bits{$_}{7} = 'OPpLVALUE' for qw(leave leaveloop); $bits{$_}{4} = 'OPpLVAL_DEFER' for qw(aelem helem); -$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvref padav padhv padrange padsv pushmark rv2av rv2gv rv2hv rv2sv sbind); +$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvref lvrefslice padav padhv padrange padsv pushmark rv2av rv2gv rv2hv rv2sv sbind); $bits{$_}{2} = 'OPpLVREF_ELEM' for qw(lvref sbind); $bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice padav padhv pos rkeys rv2av rv2gv rv2hv substr vec); $bits{$_}{6} = 'OPpMAYBE_TRUEBOOL' for qw(padhv rv2hv); diff --git a/op.c b/op.c index bb72809..fabeb2e 100644 --- a/op.c +++ b/op.c @@ -2631,6 +2631,11 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) kid->op_private |= OPpLVREF_ELEM; kid->op_flags |= OPf_STACKED; break; + case OP_ASLICE: + kid->op_type = OP_LVREFSLICE; + kid->op_ppaddr = PL_ppaddr[OP_LVREFSLICE]; + kid->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM; + continue; default: badref: /* diag_listed_as: Can't modify %s in %s */ diff --git a/opcode.h b/opcode.h index c2999b4..547d930 100644 --- a/opcode.h +++ b/opcode.h @@ -529,6 +529,7 @@ EXTCONST char* const PL_op_name[] = { "padrange", "sbind", "lvref", + "lvrefslice", "freed", }; #endif @@ -918,6 +919,7 @@ EXTCONST char* const PL_op_desc[] = { "list of private variables", "lvalue ref assignment", "lvalue ref assignment", + "lvalue ref assignment", "freed op", }; #endif @@ -1321,6 +1323,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ Perl_pp_padrange, Perl_pp_sbind, Perl_pp_lvref, + Perl_pp_lvrefslice, } #endif #ifdef PERL_PPADDR_INITED @@ -1720,6 +1723,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ Perl_ck_null, /* padrange */ Perl_ck_sbind, /* sbind */ Perl_ck_null, /* lvref */ + Perl_ck_null, /* lvrefslice */ } #endif #ifdef PERL_CHECK_INITED @@ -2113,6 +2117,7 @@ EXTCONST U32 PL_opargs[] = { 0x00000040, /* padrange */ 0x00000240, /* sbind */ 0x00000140, /* lvref */ + 0x00000440, /* lvrefslice */ }; #endif @@ -2724,6 +2729,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 628, /* padrange */ 630, /* sbind */ 633, /* lvref */ + 636, /* lvrefslice */ }; @@ -3083,6 +3089,7 @@ EXTCONST U16 PL_op_private_bitdefs[] = { /* padrange */ 0x265c, 0x019b, /* sbind */ 0x265c, 0x1328, 0x0067, /* lvref */ 0x265c, 0x1328, 0x0003, + /* lvrefslice */ 0x265d, }; @@ -3472,6 +3479,7 @@ EXTCONST U8 PL_op_private_valid[] = { /* PADRANGE */ (OPpPADRANGE_COUNTMASK|OPpLVAL_INTRO), /* SBIND */ (OPpARG2_MASK|OPpLVREF_ELEM|OPpLVAL_INTRO), /* LVREF */ (OPpARG1_MASK|OPpLVREF_ELEM|OPpLVAL_INTRO), + /* LVREFSLICE */ (OPpLVAL_INTRO), }; diff --git a/opnames.h b/opnames.h index 93c638d..f6d9d64 100644 --- a/opnames.h +++ b/opnames.h @@ -395,10 +395,11 @@ typedef enum opcode { OP_PADRANGE = 378, OP_SBIND = 379, OP_LVREF = 380, + OP_LVREFSLICE = 381, OP_max } opcode; -#define MAXO 381 +#define MAXO 382 #define OP_FREED MAXO /* the OP_IS_* macros are optimized to a simple range check because diff --git a/pp.c b/pp.c index f9d87bd..09426e1 100644 --- a/pp.c +++ b/pp.c @@ -6200,7 +6200,7 @@ PP(pp_lvref) SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL; sv_magic(ret, arg, PERL_MAGIC_lvref, (char *)elem, elem ? HEf_SVKEY : ARGTARG); - if (PL_op->op_private & OPpLVAL_INTRO) + if (PL_op->op_private & OPpLVAL_INTRO) { if (PL_op->op_flags & OPf_STACKED) { save_pushptrptr((GV *)arg, SvREFCNT_inc_simple(GvSV(arg)), SAVEt_GVSV); @@ -6208,10 +6208,61 @@ PP(pp_lvref) } else SAVECLEARSV(PAD_SVl(ARGTARG)); + } XPUSHs(ret); RETURN; } +PP(pp_lvrefslice) +{ + dSP; dMARK; dORIGMARK; + AV * const av = (AV *)POPs; + const bool localizing = PL_op->op_private & OPpLVAL_INTRO; + bool can_preserve = FALSE; + + if (localizing) { + MAGIC *mg; + HV *stash; + SV **svp; + + can_preserve = SvCANEXISTDELETE(av); + + if (SvTYPE(av) == SVt_PVAV) { + SSize_t max = -1; + + for (svp = MARK + 1; svp <= SP; svp++) { + const SSize_t elem = SvIV(*svp); + if (elem > max) + max = elem; + } + if (max > AvMAX(av)) + av_extend(av, max); + } + } + + while (++MARK <= SP) { + SV * const elemsv = *MARK; + const SSize_t elem = SvIV(elemsv); + bool existent = TRUE; + + if (localizing && can_preserve) + existent = av_exists(av, elem); + + if (localizing && existent) { + SV ** const svp = av_fetch(av, elem, 1); + if (!svp || !*svp) + DIE(aTHX_ PL_no_aelem, elem); + save_aelem(av, elem, svp); + } + else + SAVEADELETE(av, elem); + + *MARK = sv_2mortal(newSV_type(SVt_PVMG)); + sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY); + } + RETURN; +} + /* * Local variables: * c-indentation-style: bsd diff --git a/pp_proto.h b/pp_proto.h index 8704e65..aef3b0b 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -146,6 +146,7 @@ PERL_CALLCONV OP *Perl_pp_lock(pTHX); PERL_CALLCONV OP *Perl_pp_lslice(pTHX); PERL_CALLCONV OP *Perl_pp_lt(pTHX); PERL_CALLCONV OP *Perl_pp_lvref(pTHX); +PERL_CALLCONV OP *Perl_pp_lvrefslice(pTHX); PERL_CALLCONV OP *Perl_pp_mapwhile(pTHX); PERL_CALLCONV OP *Perl_pp_match(pTHX); PERL_CALLCONV OP *Perl_pp_method(pTHX); diff --git a/regen/op_private b/regen/op_private index a6e0fbc..9acfb8a 100644 --- a/regen/op_private +++ b/regen/op_private @@ -300,7 +300,7 @@ for (qw(nextstate dbstate)) { addbits($_, 7 => qw(OPpLVAL_INTRO LVINTRO)) for qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice hslice delete padsv padav padhv enteriter entersub padrange - pushmark cond_expr sbind lvref), + pushmark cond_expr sbind lvref lvrefslice), 'list', # this gets set in my_attrs() for some reason ; diff --git a/regen/opcodes b/regen/opcodes index 97cbc69..64590d2 100644 --- a/regen/opcodes +++ b/regen/opcodes @@ -555,3 +555,4 @@ clonecv private subroutine ck_null d0 padrange list of private variables ck_null d0 sbind lvalue ref assignment ck_sbind d2 lvref lvalue ref assignment ck_null d1 +lvrefslice lvalue ref assignment ck_null d@ diff --git a/t/op/lvref.t b/t/op/lvref.t index f9aff2a..4c7c24c 100644 --- a/t/op/lvref.t +++ b/t/op/lvref.t @@ -4,7 +4,7 @@ BEGIN { set_up_inc("../lib"); } -plan 48; +plan 52; sub on { $::TODO = ' ' } sub off{ $::TODO = '' } @@ -76,17 +76,32 @@ is *foo{SCALAR}, *bar{GLOB}, 'globref-to-scalarref assignment'; # Array Elements -\$a[0] = \$_; +sub expect_scalar_cx { wantarray ? 0 : \$_ } +sub expect_list_cx { wantarray ? (\$_,\$_) : 0 } +\$a[0] = expect_scalar_cx; is \$a[0], \$_, '\$array[0]'; -\($a[1]) = \$_; +\($a[1]) = expect_list_cx; is \$a[1], \$_, '\($array[0])'; { my @a; - \$a[0] = \$_; + \$a[0] = expect_scalar_cx; is \$a[0], \$_, '\$lexical_array[0]'; - \($a[1]) = \$_; + \($a[1]) = expect_list_cx; is \$a[1], \$_, '\($lexical_array[0])'; } +{ + my @a; + \@a[0,1] = expect_list_cx; + is \$a[0].\$a[1], \$_.\$_, '\@array[indices]'; + \(@a[2,3]) = expect_list_cx; + is \$a[0].\$a[1], \$_.\$_, '\(@array[indices])'; + my $tmp; + { + \local @a[0,1] = (\$tmp)x2; + is \$a[0].\$a[1], \$tmp.\$tmp, '\local @a[indices]'; + } + is \$a[0].\$a[1], \$_.\$_, '\local @a[indices] unwound'; +} # Hash Elements -- Perl5 Master Repository
