First stab at lexical scalar aliases

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.

diff --git a/embed.fnc b/embed.fnc
index a0cac62..0da1b26 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1925,7 +1925,7 @@ s |void   |fixup_errno_string|NN SV* sv
 
 #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

diff --git a/embed.h b/embed.h
index d73816f..039961e 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1108,6 +1108,7 @@
 #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)
@@ -1508,6 +1509,7 @@
 #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)
@@ -1521,7 +1523,6 @@
 #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)

diff --git a/op.c b/op.c
index fc93244..bd85fd2 100644 (file)
--- a/op.c
+++ b/op.c
@@ -5661,8 +5661,11 @@ Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
            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;
@@ -5677,16 +5680,19 @@ S_is_list_assignment(pTHX_ const OP *o)
     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)
@@ -5800,6 +5806,7 @@ OP *
 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) {
@@ -5813,7 +5820,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
        }
     }
 
-    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;
@@ -5972,6 +5979,8 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
        }
        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) {
@@ -9853,6 +9862,42 @@ Perl_ck_open(pTHX_ OP *o)
 }
 
 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;

diff --git a/opcode.h b/opcode.h
index 86e42b0..6121653 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -1715,7 +1715,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
        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

diff --git a/pp.c b/pp.c
index 7a34e24..df9085c 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -6162,7 +6162,18 @@ PP(pp_runcv)
 
 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;
 }
 
 

diff --git a/proto.h b/proto.h
index c7d86dd..dd90f3f 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -573,6 +573,12 @@ PERL_CALLCONV OP * Perl_ck_readline(pTHX_ OP *o)
 #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);
@@ -6176,6 +6182,9 @@ STATIC void       S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp
 #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)
@@ -6240,9 +6249,6 @@ STATIC bool       S_is_handle_constructor(const OP *o, I32 numargs)
 #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);

diff --git a/regen/opcodes b/regen/opcodes
index 6e33211..c40e3f9 100644 (file)
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -553,4 +553,4 @@ padcv               private subroutine      ck_null         d0
 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

diff --git a/scope.c b/scope.c
index 9fd2546..0f819e7 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -1007,8 +1007,6 @@ Perl_leave_scope(pTHX_ I32 base)
                     (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
                 ));
 
-                assert(SvPADMY(sv));
-
                 /* Can clear pad variable in place? */
                 if (SvREFCNT(sv) == 1 && !SvOBJECT(sv)) {