No \my$x= yet. Only my $x; \$x =....
It does not work properly with variables closed over from outside;
hence, all the to-do tests fail still, since they do the assign-
ment in evals.
But this much works:
$ ./miniperl -Ilib -Mfeature=:all -e 'my $m; \$m = \$n; warn \$m; warn \$n'
Lvalue references are experimental at -e line 1.
SCALAR(0x7fa04b805510) at -e line 1.
SCALAR(0x7fa04b805510) at -e line 1.
#if defined(PERL_IN_OP_C)
sRn |bool |is_handle_constructor|NN const OP *o|I32 numargs
-sR |I32 |is_list_assignment|NULLOK const OP *o
+sR |I32 |assignment_type|NULLOK const OP *o
s |void |forget_pmop |NN PMOP *const o
s |void |find_and_forget_pmops |NN OP *o
s |void |cop_free |NN COP *cop
#define ck_null(a) Perl_ck_null(aTHX_ a)
#define ck_open(a) Perl_ck_open(aTHX_ a)
#define ck_readline(a) Perl_ck_readline(aTHX_ a)
+#define ck_refassign(a) Perl_ck_refassign(aTHX_ a)
#define ck_repeat(a) Perl_ck_repeat(aTHX_ a)
#define ck_require(a) Perl_ck_require(aTHX_ a)
#define ck_return(a) Perl_ck_return(aTHX_ a)
#define aassign_common_vars(a) S_aassign_common_vars(aTHX_ a)
#define apply_attrs(a,b,c) S_apply_attrs(aTHX_ a,b,c)
#define apply_attrs_my(a,b,c,d) S_apply_attrs_my(aTHX_ a,b,c,d)
+#define assignment_type(a) S_assignment_type(aTHX_ a)
#define bad_type_gv(a,b,c,d,e) S_bad_type_gv(aTHX_ a,b,c,d,e)
#define bad_type_pv(a,b,c,d,e) S_bad_type_pv(aTHX_ a,b,c,d,e)
#define clear_special_blocks(a,b,c) S_clear_special_blocks(aTHX_ a,b,c)
#define gen_constant_list(a) S_gen_constant_list(aTHX_ a)
#define inplace_aassign(a) S_inplace_aassign(aTHX_ a)
#define is_handle_constructor S_is_handle_constructor
-#define is_list_assignment(a) S_is_list_assignment(aTHX_ a)
#define listkids(a) S_listkids(aTHX_ a)
#define looks_like_bool(a) S_looks_like_bool(aTHX_ a)
#define modkids(a,b) S_modkids(aTHX_ a,b)
list(force_list(listval, 1)) );
}
+#define ASSIGN_LIST 1
+#define ASSIGN_REF 2
+
STATIC I32
-S_is_list_assignment(pTHX_ const OP *o)
+S_assignment_type(pTHX_ const OP *o)
{
unsigned type;
U8 flags;
type = o->op_type;
if (type == OP_COND_EXPR) {
OP * const sib = OP_SIBLING(cLOGOPo->op_first);
- const I32 t = is_list_assignment(sib);
- const I32 f = is_list_assignment(OP_SIBLING(sib));
+ const I32 t = assignment_type(sib);
+ const I32 f = assignment_type(OP_SIBLING(sib));
- if (t && f)
- return TRUE;
- if (t || f)
+ if (t == f)
+ return t;
+ if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
yyerror("Assignment to both a list and a scalar");
return FALSE;
}
+ if (type == OP_SREFGEN)
+ return ASSIGN_REF;
+
if (type == OP_LIST &&
(flags & OPf_WANT) == OPf_WANT_SCALAR &&
o->op_private & OPpLVAL_INTRO)
Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
{
OP *o;
+ I32 assign_type;
if (optype) {
if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
}
}
- if (is_list_assignment(left)) {
+ if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
static const char no_list_state[] = "Initialization of state variables"
" in list context currently forbidden";
OP *curop;
}
return o;
}
+ if (assign_type == ASSIGN_REF)
+ return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
if (!right)
right = newOP(OP_UNDEF, 0);
if (right->op_type == OP_READLINE) {
}
OP *
+Perl_ck_refassign(pTHX_ OP *o)
+{
+ OP * const right = cLISTOPo->op_first;
+ OP * const left = OP_SIBLING(right);
+ OP * const varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
+ PADOFFSET targ;
+
+ PERL_ARGS_ASSERT_CK_REFASSIGN;
+ assert (left);
+ assert (left->op_type == OP_SREFGEN);
+
+ switch (varop->op_type) {
+ case OP_PADSV:
+ if (varop->op_private & OPpLVAL_INTRO)
+ goto bad; /* XXX temporary */
+ targ = varop->op_targ;
+ varop->op_targ = 0;
+ break;
+ default:
+ bad:
+ op_lvalue(left, OP_SASSIGN);
+ return o;
+ }
+ if (!FEATURE_LVREF_IS_ENABLED)
+ Perl_croak(aTHX_
+ "Experimental lvalue references not enabled");
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__LVALUE_REFS),
+ "Lvalue references are experimental");
+ o->op_targ = targ;
+ op_sibling_splice(o, right, 1, NULL);
+ op_free(left);
+ return o;
+}
+
+OP *
Perl_ck_repeat(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_REPEAT;
Perl_ck_null, /* introcv */
Perl_ck_null, /* clonecv */
Perl_ck_null, /* padrange */
- Perl_ck_null, /* refassign */
+ Perl_ck_refassign, /* refassign */
}
#endif
#ifdef PERL_CHECK_INITED
PP(pp_refassign)
{
- DIE(aTHX_ "Unimplemented");
+ dSP;
+ dTOPss;
+ if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
+ if (SvTYPE(SvRV(sv)) > SVt_PVLV)
+ DIE(aTHX_ "Assigned value is not a scalar reference");
+ SvREFCNT_dec(PAD_SV(ARGTARG));
+ PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
+ if (PL_op->op_flags & OPf_MOD)
+ SETs(sv_2mortal(newSVsv(sv)));
+ /* XXX else can weak references go stale before they are read, e.g.,
+ in leavesub? */
+ RETURN;
}
#define PERL_ARGS_ASSERT_CK_READLINE \
assert(o)
+PERL_CALLCONV OP * Perl_ck_refassign(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_REFASSIGN \
+ assert(o)
+
PERL_CALLCONV OP * Perl_ck_repeat(pTHX_ OP *o)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_APPLY_ATTRS_MY \
assert(stash); assert(target); assert(imopsp)
+STATIC I32 S_assignment_type(pTHX_ const OP *o)
+ __attribute__warn_unused_result__;
+
STATIC void S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
__attribute__nonnull__(pTHX_2)
__attribute__nonnull__(pTHX_3)
#define PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR \
assert(o)
-STATIC I32 S_is_list_assignment(pTHX_ const OP *o)
- __attribute__warn_unused_result__;
-
STATIC OP* S_listkids(pTHX_ OP* o);
STATIC bool S_looks_like_bool(pTHX_ const OP* o)
__attribute__nonnull__(pTHX_1);
introcv private subroutine ck_null d0
clonecv private subroutine ck_null d0
padrange list of private variables ck_null d0
-refassign lvalue ref assignment ck_null d2
+refassign lvalue ref assignment ck_refassign d2
(SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
));
- assert(SvPADMY(sv));
-
/* Can clear pad variable in place? */
if (SvREFCNT(sv) == 1 && !SvOBJECT(sv)) {