This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
initial implementation of lvalue subroutines (slightly fixed
authorGurusamy Sarathy <gsar@cpan.org>
Sun, 5 Sep 1999 22:07:18 +0000 (22:07 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Sun, 5 Sep 1999 22:07:18 +0000 (22:07 +0000)
version of patch suggested by Ilya Zakharevich, which in turn
is based on the one suggested by Tuomas J. Lukka <lukka@iki.fi>)

p4raw-id: //depot/perl@4081

23 files changed:
MANIFEST
cop.h
cv.h
dump.c
embed.h
ext/Opcode/Opcode.pm
ext/attrs/attrs.pm
ext/attrs/attrs.xs
objXSUB.h
op.c
op.h
opcode.h
opcode.pl
opnames.h
perlapi.c
pod/perldiag.pod
pod/perlsub.pod
pp.c
pp.sym
pp_hot.c
pp_proto.h
t/pragma/sub_lval.t [new file with mode: 0755]
t/pragma/warn/pp_ctl

index f5ea95c..6bd774f 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1345,6 +1345,7 @@ t/pragma/strict-subs      Tests of "use strict 'subs'" for strict.t
 t/pragma/strict-vars   Tests of "use strict 'vars'" for strict.t
 t/pragma/strict.t      See if strictures work
 t/pragma/subs.t                See if subroutine pseudo-importation works
+t/pragma/sub_lval.t    See if lvalue subroutines work
 t/pragma/utf8.t                See if utf8 operations work
 t/pragma/warn/1global  Tests of global warnings for warnings.t
 t/pragma/warn/2use     Tests for "use warnings" for warnings.t
diff --git a/cop.h b/cop.h
index f23251b..d0a59a0 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -35,12 +35,15 @@ struct block_sub {
     AV *       argarray;
     U16                olddepth;
     U8         hasargs;
+    U8         lval;           /* XXX merge lval and hasargs? */
 };
 
 #define PUSHSUB(cx)                                                    \
        cx->blk_sub.cv = cv;                                            \
        cx->blk_sub.olddepth = CvDEPTH(cv);                             \
-       cx->blk_sub.hasargs = hasargs;
+       cx->blk_sub.hasargs = hasargs;                                  \
+       cx->blk_sub.lval = PL_op->op_private &                          \
+                             (OPpLVAL_INTRO|OPpENTERSUB_INARGS);
 
 #define PUSHFORMAT(cx)                                                 \
        cx->blk_sub.cv = cv;                                            \
diff --git a/cv.h b/cv.h
index 7042708..67d4a8e 100644 (file)
--- a/cv.h
+++ b/cv.h
@@ -62,6 +62,7 @@ struct xpvcv {
                                   (esp. useful for special XSUBs) */
 #define CVf_METHOD     0x0040  /* CV is explicitly marked as a method */
 #define CVf_LOCKED     0x0080  /* CV locks itself or first arg on entry */
+#define CVf_LVALUE     0x0100  /* CV return value can be used as lvalue */
 
 #define CvCLONE(cv)            (CvFLAGS(cv) & CVf_CLONE)
 #define CvCLONE_on(cv)         (CvFLAGS(cv) |= CVf_CLONE)
@@ -97,6 +98,10 @@ struct xpvcv {
 #define CvLOCKED_on(cv)                (CvFLAGS(cv) |= CVf_LOCKED)
 #define CvLOCKED_off(cv)       (CvFLAGS(cv) &= ~CVf_LOCKED)
 
+#define CvLVALUE(cv)           (CvFLAGS(cv) & CVf_LVALUE)
+#define CvLVALUE_on(cv)                (CvFLAGS(cv) |= CVf_LVALUE)
+#define CvLVALUE_off(cv)       (CvFLAGS(cv) &= ~CVf_LVALUE)
+
 #define CvEVAL(cv)             (CvUNIQUE(cv) && !SvFAKE(cv))
 #define CvEVAL_on(cv)          (CvUNIQUE_on(cv),SvFAKE_off(cv))
 #define CvEVAL_off(cv)         CvUNIQUE_off(cv)
diff --git a/dump.c b/dump.c
index 0e7de38..1ec22f2 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -509,6 +509,9 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
        else if (o->op_type == OP_FLOP) {
            if (o->op_private & OPpFLIP_LINENUM)
                sv_catpv(tmpsv, ",LINENUM");
+       } else if (o->op_type == OP_RV2CV) {
+           if (o->op_private & OPpLVAL_INTRO)
+               sv_catpv(tmpsv, ",INTRO");
        }
        if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
            sv_catpv(tmpsv, ",INTRO");
diff --git a/embed.h b/embed.h
index 1d33518..21f5f36 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define pp_leaveeval           Perl_pp_leaveeval
 #define pp_leaveloop           Perl_pp_leaveloop
 #define pp_leavesub            Perl_pp_leavesub
+#define pp_leavesublv          Perl_pp_leavesublv
 #define pp_leavetry            Perl_pp_leavetry
 #define pp_leavewrite          Perl_pp_leavewrite
 #define pp_left_shift          Perl_pp_left_shift
 #define pp_leaveeval()         Perl_pp_leaveeval(aTHX)
 #define pp_leaveloop()         Perl_pp_leaveloop(aTHX)
 #define pp_leavesub()          Perl_pp_leavesub(aTHX)
+#define pp_leavesublv()                Perl_pp_leavesublv(aTHX)
 #define pp_leavetry()          Perl_pp_leavetry(aTHX)
 #define pp_leavewrite()                Perl_pp_leavewrite(aTHX)
 #define pp_left_shift()                Perl_pp_left_shift(aTHX)
 #define pp_leaveloop           Perl_pp_leaveloop
 #define Perl_pp_leavesub       CPerlObj::Perl_pp_leavesub
 #define pp_leavesub            Perl_pp_leavesub
+#define Perl_pp_leavesublv     CPerlObj::Perl_pp_leavesublv
+#define pp_leavesublv          Perl_pp_leavesublv
 #define Perl_pp_leavetry       CPerlObj::Perl_pp_leavetry
 #define pp_leavetry            Perl_pp_leavetry
 #define Perl_pp_leavewrite     CPerlObj::Perl_pp_leavewrite
index 38c8e65..ff3899f 100644 (file)
@@ -336,7 +336,7 @@ invert_opset function.
 
     rv2cv anoncode prototype
 
-    entersub leavesub return method method_named -- XXX loops via recursion?
+    entersub leavesub leavesublv return method method_named -- XXX loops via recursion?
 
     leaveeval -- needed for Safe to operate, is safe without entereval
 
index fe2bf35..e97fa1e 100644 (file)
@@ -46,6 +46,11 @@ execution. The semantics of the lock are exactly those of one
 explicitly taken with the C<lock> operator immediately after the
 subroutine is entered.
 
+=item lvalue
+
+Setting this attribute enables the subroutine to be used in
+lvalue context.  See L<perlsub/"Lvalue subroutines">.
+
 =back
 
 =cut
index 53ba535..a92922d 100644 (file)
@@ -10,6 +10,8 @@ get_flag(char *attr)
        return CVf_METHOD;
     else if (strnEQ(attr, "locked", 6))
        return CVf_LOCKED;
+    else if (strnEQ(attr, "lvalue", 6))
+       return CVf_LVALUE;
     else
        return 0;
 }
index e7b34b1..abb9f39 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #define Perl_pp_leavesub       pPerl->Perl_pp_leavesub
 #undef  pp_leavesub
 #define pp_leavesub            Perl_pp_leavesub
+#undef  Perl_pp_leavesublv
+#define Perl_pp_leavesublv     pPerl->Perl_pp_leavesublv
+#undef  pp_leavesublv
+#define pp_leavesublv          Perl_pp_leavesublv
 #undef  Perl_pp_leavetry
 #define Perl_pp_leavetry       pPerl->Perl_pp_leavetry
 #undef  pp_leavetry
diff --git a/op.c b/op.c
index 57ff104..ae477d8 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1239,6 +1239,91 @@ Perl_mod(pTHX_ OP *o, I32 type)
            null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
            break;
        }
+       else {                          /* lvalue subroutine call */
+           o->op_private |= OPpLVAL_INTRO;
+           if (type == OP_GREPSTART || type == OP_ENTERSUB) {
+               /* Backward compatibility mode: */
+               o->op_private |= OPpENTERSUB_INARGS;
+               break;
+           }
+           else {                      /* Compile-time error message: */
+               OP *kid = cUNOPo->op_first;
+               CV *cv;
+               OP *okid;
+
+               if (kid->op_type == OP_PUSHMARK)
+                   goto skip_kids;
+               if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
+                   Perl_croak(aTHX_
+                              "panic: unexpected lvalue entersub "
+                              "args: type/targ %ld:%ld",
+                              (long)kid->op_type,kid->op_targ);
+               kid = kLISTOP->op_first;
+             skip_kids:
+               while (kid->op_sibling)
+                   kid = kid->op_sibling;
+               if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
+                   /* Indirect call */
+                   if (kid->op_type == OP_METHOD_NAMED
+                       || kid->op_type == OP_METHOD)
+                   {
+                       OP *new;
+
+                       if (kid->op_sibling || kid->op_next != kid) {
+                           yyerror("panic: unexpected optree near method call");
+                           break;
+                       }
+                       
+                       NewOp(1101, new, 1, OP);
+                       new->op_type = OP_RV2CV;
+                       new->op_ppaddr = PL_ppaddr[OP_RV2CV];
+                       new->op_next = new;
+                       kid->op_sibling = new;
+                       new->op_private |= OPpLVAL_INTRO;
+                       break;
+                   }
+                   
+                   if (kid->op_type != OP_RV2CV)
+                       Perl_croak(aTHX_
+                                  "panic: unexpected lvalue entersub "
+                                  "entry via type/targ %ld:%ld",
+                                  (long)kid->op_type,kid->op_targ);
+                   kid->op_private |= OPpLVAL_INTRO;
+                   break;      /* Postpone until runtime */
+               }
+               
+               okid = kid;             
+               kid = kUNOP->op_first;
+               if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
+                   kid = kUNOP->op_first;
+               if (kid->op_type == OP_NULL)            
+                   Perl_croak(aTHX_
+                              "Unexpected constant lvalue entersub "
+                              "entry via type/targ %ld:%ld",
+                              (long)kid->op_type,kid->op_targ);
+               if (kid->op_type != OP_GV) {
+                   /* Restore RV2CV to check lvalueness */
+                 restore_2cv:
+                   if (kid->op_next && kid->op_next != kid) { /* Happens? */
+                       okid->op_next = kid->op_next;
+                       kid->op_next = okid;
+                   }
+                   else
+                       okid->op_next = Nullop;
+                   okid->op_type = OP_RV2CV;
+                   okid->op_targ = 0;
+                   okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
+                   okid->op_private |= OPpLVAL_INTRO;
+                   break;
+               }
+               
+               cv = GvCV(kGVOP->op_gv);
+               if (!cv) 
+                   goto restore_2cv;
+               if (CvLVALUE(cv))
+                   break;
+           }
+       }
        /* FALL THROUGH */
     default:
       nomod:
@@ -1247,7 +1332,10 @@ Perl_mod(pTHX_ OP *o, I32 type)
            break;
        yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
                     (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
-                     ? "do block" : PL_op_desc[o->op_type]),
+                     ? "do block"
+                     : (o->op_type == OP_ENTERSUB
+                       ? "non-lvalue subroutine call"
+                       : PL_op_desc[o->op_type])),
                     type ? PL_op_desc[type] : "local"));
        return o;
 
@@ -4207,7 +4295,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        }
     }
 
-    CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+    if(CvLVALUE(cv)) {
+       CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
+    }
+    else {
+       CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+    }
     CvSTART(cv) = LINKLIST(CvROOT(cv));
     CvROOT(cv)->op_next = 0;
     peep(CvSTART(cv));
@@ -5825,6 +5918,7 @@ Perl_peep(pTHX_ register OP *o)
     dTHR;
     register OP* oldop = 0;
     STRLEN n_a;
+    OP *last_composite = Nullop;
 
     if (!o || o->op_seq)
        return;
@@ -5843,6 +5937,7 @@ Perl_peep(pTHX_ register OP *o)
        case OP_DBSTATE:
            PL_curcop = ((COP*)o);              /* for warnings */
            o->op_seq = PL_op_seqmax++;
+           last_composite = Nullop;
            break;
 
        case OP_CONST:
@@ -5871,7 +5966,8 @@ Perl_peep(pTHX_ register OP *o)
                            && (((LISTOP*)o)->op_first->op_sibling->op_targ
                                == o->op_next->op_targ))) {
                        goto ignore_optimization;
-                   } else {
+                   }
+                   else {
                        o->op_targ = o->op_next->op_targ;
                        o->op_private |= OPpTARGET_MY;
                    }
@@ -6040,6 +6136,40 @@ Perl_peep(pTHX_ register OP *o)
            break;
        }
 
+       case OP_RV2AV:
+       case OP_RV2HV:
+           if (!(o->op_flags & OPf_WANT)
+               || o->op_flags & OPf_WANT == OPf_WANT_LIST)
+               last_composite = o;
+           o->op_seq = PL_op_seqmax++;
+           break;
+
+       case OP_RETURN:
+           if (o->op_next->op_type != OP_LEAVESUBLV) {
+               o->op_seq = PL_op_seqmax++;
+               break;
+           }
+           /* FALL THROUGH */
+
+       case OP_LEAVESUBLV:
+           if (last_composite) {
+               OP *r = last_composite;
+
+               while (r->op_sibling)
+                  r = r->op_sibling;
+               if (r->op_next == o 
+                   || (r->op_next->op_type == OP_LIST
+                       && r->op_next->op_next == o))
+               {
+                   if (last_composite->op_type == OP_RV2AV)
+                       yyerror("Lvalue subs returning arrays not implemented yet");
+                   else
+                       yyerror("Lvalue subs returning hashes not implemented yet");
+                       ;
+               }               
+           }
+           /* FALL THROUGH */
+
        default:
            o->op_seq = PL_op_seqmax++;
            break;
diff --git a/op.h b/op.h
index d1e2f27..c6938c9 100644 (file)
--- a/op.h
+++ b/op.h
@@ -92,7 +92,7 @@ typedef U32 PADOFFSET;
           : dowantarray())
 
 /* Private for lvalues */
-#define OPpLVAL_INTRO  128     /* Lvalue must be localized */
+#define OPpLVAL_INTRO  128     /* Lvalue must be localized or lvalue sub */
 
 /* Private for OP_AASSIGN */
 #define OPpASSIGN_COMMON       64      /* Left & right have syms in common. */
@@ -128,6 +128,7 @@ typedef U32 PADOFFSET;
   /* OP_RV2CV only */
 #define OPpENTERSUB_AMPER      8       /* Used & form to call. */
 #define OPpENTERSUB_NOPAREN    128     /* bare sub call (without parens) */
+#define OPpENTERSUB_INARGS     4       /* Lval used as arg to a sub. */
   /* OP_GV only */
 #define OPpEARLY_CV            32      /* foo() called before sub foo was parsed */
   /* OP_?ELEM only */
index abd180c..7ca8d48 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -183,6 +183,7 @@ EXT char *PL_op_name[] = {
        "method",
        "entersub",
        "leavesub",
+       "leavesublv",
        "caller",
        "warn",
        "die",
@@ -540,6 +541,7 @@ EXT char *PL_op_desc[] = {
        "method lookup",
        "subroutine entry",
        "subroutine exit",
+       "lvalue subroutine exit",
        "caller",
        "warn",
        "die",
@@ -902,6 +904,7 @@ EXT OP * (CPERLscope(*PL_ppaddr)[])(pTHX) = {
        Perl_pp_method,
        Perl_pp_entersub,
        Perl_pp_leavesub,
+       Perl_pp_leavesublv,
        Perl_pp_caller,
        Perl_pp_warn,
        Perl_pp_die,
@@ -1259,6 +1262,7 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = {
        Perl_ck_method, /* method */
        Perl_ck_subr,   /* entersub */
        Perl_ck_null,   /* leavesub */
+       Perl_ck_null,   /* leavesublv */
        Perl_ck_fun,    /* caller */
        Perl_ck_fun,    /* warn */
        Perl_ck_fun,    /* die */
@@ -1616,6 +1620,7 @@ EXT U32 PL_opargs[] = {
        0x00000240,     /* method */
        0x00004249,     /* entersub */
        0x00000200,     /* leavesub */
+       0x00000200,     /* leavesublv */
        0x00013608,     /* caller */
        0x0000481d,     /* warn */
        0x0000485d,     /* die */
index f112745..5b666d3 100755 (executable)
--- a/opcode.pl
+++ b/opcode.pl
@@ -549,6 +549,7 @@ orassign    logical or assignment   ck_null         s|
 method         method lookup           ck_method       d1
 entersub       subroutine entry        ck_subr         dmt1    L
 leavesub       subroutine exit         ck_null         1       
+leavesublv     lvalue subroutine exit  ck_null         1       
 caller         caller                  ck_fun          t%      S?
 warn           warn                    ck_fun          imst@   L
 die            die                     ck_fun          dimst@  L
index 417d74d..e9f8b4f 100644 (file)
--- a/opnames.h
+++ b/opnames.h
@@ -172,190 +172,191 @@ typedef enum opcode {
        OP_METHOD,      /* 165 */
        OP_ENTERSUB,    /* 166 */
        OP_LEAVESUB,    /* 167 */
-       OP_CALLER,      /* 168 */
-       OP_WARN,        /* 169 */
-       OP_DIE,         /* 170 */
-       OP_RESET,       /* 171 */
-       OP_LINESEQ,     /* 172 */
-       OP_NEXTSTATE,   /* 173 */
-       OP_DBSTATE,     /* 174 */
-       OP_UNSTACK,     /* 175 */
-       OP_ENTER,       /* 176 */
-       OP_LEAVE,       /* 177 */
-       OP_SCOPE,       /* 178 */
-       OP_ENTERITER,   /* 179 */
-       OP_ITER,        /* 180 */
-       OP_ENTERLOOP,   /* 181 */
-       OP_LEAVELOOP,   /* 182 */
-       OP_RETURN,      /* 183 */
-       OP_LAST,        /* 184 */
-       OP_NEXT,        /* 185 */
-       OP_REDO,        /* 186 */
-       OP_DUMP,        /* 187 */
-       OP_GOTO,        /* 188 */
-       OP_EXIT,        /* 189 */
-       OP_OPEN,        /* 190 */
-       OP_CLOSE,       /* 191 */
-       OP_PIPE_OP,     /* 192 */
-       OP_FILENO,      /* 193 */
-       OP_UMASK,       /* 194 */
-       OP_BINMODE,     /* 195 */
-       OP_TIE,         /* 196 */
-       OP_UNTIE,       /* 197 */
-       OP_TIED,        /* 198 */
-       OP_DBMOPEN,     /* 199 */
-       OP_DBMCLOSE,    /* 200 */
-       OP_SSELECT,     /* 201 */
-       OP_SELECT,      /* 202 */
-       OP_GETC,        /* 203 */
-       OP_READ,        /* 204 */
-       OP_ENTERWRITE,  /* 205 */
-       OP_LEAVEWRITE,  /* 206 */
-       OP_PRTF,        /* 207 */
-       OP_PRINT,       /* 208 */
-       OP_SYSOPEN,     /* 209 */
-       OP_SYSSEEK,     /* 210 */
-       OP_SYSREAD,     /* 211 */
-       OP_SYSWRITE,    /* 212 */
-       OP_SEND,        /* 213 */
-       OP_RECV,        /* 214 */
-       OP_EOF,         /* 215 */
-       OP_TELL,        /* 216 */
-       OP_SEEK,        /* 217 */
-       OP_TRUNCATE,    /* 218 */
-       OP_FCNTL,       /* 219 */
-       OP_IOCTL,       /* 220 */
-       OP_FLOCK,       /* 221 */
-       OP_SOCKET,      /* 222 */
-       OP_SOCKPAIR,    /* 223 */
-       OP_BIND,        /* 224 */
-       OP_CONNECT,     /* 225 */
-       OP_LISTEN,      /* 226 */
-       OP_ACCEPT,      /* 227 */
-       OP_SHUTDOWN,    /* 228 */
-       OP_GSOCKOPT,    /* 229 */
-       OP_SSOCKOPT,    /* 230 */
-       OP_GETSOCKNAME, /* 231 */
-       OP_GETPEERNAME, /* 232 */
-       OP_LSTAT,       /* 233 */
-       OP_STAT,        /* 234 */
-       OP_FTRREAD,     /* 235 */
-       OP_FTRWRITE,    /* 236 */
-       OP_FTREXEC,     /* 237 */
-       OP_FTEREAD,     /* 238 */
-       OP_FTEWRITE,    /* 239 */
-       OP_FTEEXEC,     /* 240 */
-       OP_FTIS,        /* 241 */
-       OP_FTEOWNED,    /* 242 */
-       OP_FTROWNED,    /* 243 */
-       OP_FTZERO,      /* 244 */
-       OP_FTSIZE,      /* 245 */
-       OP_FTMTIME,     /* 246 */
-       OP_FTATIME,     /* 247 */
-       OP_FTCTIME,     /* 248 */
-       OP_FTSOCK,      /* 249 */
-       OP_FTCHR,       /* 250 */
-       OP_FTBLK,       /* 251 */
-       OP_FTFILE,      /* 252 */
-       OP_FTDIR,       /* 253 */
-       OP_FTPIPE,      /* 254 */
-       OP_FTLINK,      /* 255 */
-       OP_FTSUID,      /* 256 */
-       OP_FTSGID,      /* 257 */
-       OP_FTSVTX,      /* 258 */
-       OP_FTTTY,       /* 259 */
-       OP_FTTEXT,      /* 260 */
-       OP_FTBINARY,    /* 261 */
-       OP_CHDIR,       /* 262 */
-       OP_CHOWN,       /* 263 */
-       OP_CHROOT,      /* 264 */
-       OP_UNLINK,      /* 265 */
-       OP_CHMOD,       /* 266 */
-       OP_UTIME,       /* 267 */
-       OP_RENAME,      /* 268 */
-       OP_LINK,        /* 269 */
-       OP_SYMLINK,     /* 270 */
-       OP_READLINK,    /* 271 */
-       OP_MKDIR,       /* 272 */
-       OP_RMDIR,       /* 273 */
-       OP_OPEN_DIR,    /* 274 */
-       OP_READDIR,     /* 275 */
-       OP_TELLDIR,     /* 276 */
-       OP_SEEKDIR,     /* 277 */
-       OP_REWINDDIR,   /* 278 */
-       OP_CLOSEDIR,    /* 279 */
-       OP_FORK,        /* 280 */
-       OP_WAIT,        /* 281 */
-       OP_WAITPID,     /* 282 */
-       OP_SYSTEM,      /* 283 */
-       OP_EXEC,        /* 284 */
-       OP_KILL,        /* 285 */
-       OP_GETPPID,     /* 286 */
-       OP_GETPGRP,     /* 287 */
-       OP_SETPGRP,     /* 288 */
-       OP_GETPRIORITY, /* 289 */
-       OP_SETPRIORITY, /* 290 */
-       OP_TIME,        /* 291 */
-       OP_TMS,         /* 292 */
-       OP_LOCALTIME,   /* 293 */
-       OP_GMTIME,      /* 294 */
-       OP_ALARM,       /* 295 */
-       OP_SLEEP,       /* 296 */
-       OP_SHMGET,      /* 297 */
-       OP_SHMCTL,      /* 298 */
-       OP_SHMREAD,     /* 299 */
-       OP_SHMWRITE,    /* 300 */
-       OP_MSGGET,      /* 301 */
-       OP_MSGCTL,      /* 302 */
-       OP_MSGSND,      /* 303 */
-       OP_MSGRCV,      /* 304 */
-       OP_SEMGET,      /* 305 */
-       OP_SEMCTL,      /* 306 */
-       OP_SEMOP,       /* 307 */
-       OP_REQUIRE,     /* 308 */
-       OP_DOFILE,      /* 309 */
-       OP_ENTEREVAL,   /* 310 */
-       OP_LEAVEEVAL,   /* 311 */
-       OP_ENTERTRY,    /* 312 */
-       OP_LEAVETRY,    /* 313 */
-       OP_GHBYNAME,    /* 314 */
-       OP_GHBYADDR,    /* 315 */
-       OP_GHOSTENT,    /* 316 */
-       OP_GNBYNAME,    /* 317 */
-       OP_GNBYADDR,    /* 318 */
-       OP_GNETENT,     /* 319 */
-       OP_GPBYNAME,    /* 320 */
-       OP_GPBYNUMBER,  /* 321 */
-       OP_GPROTOENT,   /* 322 */
-       OP_GSBYNAME,    /* 323 */
-       OP_GSBYPORT,    /* 324 */
-       OP_GSERVENT,    /* 325 */
-       OP_SHOSTENT,    /* 326 */
-       OP_SNETENT,     /* 327 */
-       OP_SPROTOENT,   /* 328 */
-       OP_SSERVENT,    /* 329 */
-       OP_EHOSTENT,    /* 330 */
-       OP_ENETENT,     /* 331 */
-       OP_EPROTOENT,   /* 332 */
-       OP_ESERVENT,    /* 333 */
-       OP_GPWNAM,      /* 334 */
-       OP_GPWUID,      /* 335 */
-       OP_GPWENT,      /* 336 */
-       OP_SPWENT,      /* 337 */
-       OP_EPWENT,      /* 338 */
-       OP_GGRNAM,      /* 339 */
-       OP_GGRGID,      /* 340 */
-       OP_GGRENT,      /* 341 */
-       OP_SGRENT,      /* 342 */
-       OP_EGRENT,      /* 343 */
-       OP_GETLOGIN,    /* 344 */
-       OP_SYSCALL,     /* 345 */
-       OP_LOCK,        /* 346 */
-       OP_THREADSV,    /* 347 */
-       OP_SETSTATE,    /* 348 */
-       OP_METHOD_NAMED,/* 349 */
+       OP_LEAVESUBLV,  /* 168 */
+       OP_CALLER,      /* 169 */
+       OP_WARN,        /* 170 */
+       OP_DIE,         /* 171 */
+       OP_RESET,       /* 172 */
+       OP_LINESEQ,     /* 173 */
+       OP_NEXTSTATE,   /* 174 */
+       OP_DBSTATE,     /* 175 */
+       OP_UNSTACK,     /* 176 */
+       OP_ENTER,       /* 177 */
+       OP_LEAVE,       /* 178 */
+       OP_SCOPE,       /* 179 */
+       OP_ENTERITER,   /* 180 */
+       OP_ITER,        /* 181 */
+       OP_ENTERLOOP,   /* 182 */
+       OP_LEAVELOOP,   /* 183 */
+       OP_RETURN,      /* 184 */
+       OP_LAST,        /* 185 */
+       OP_NEXT,        /* 186 */
+       OP_REDO,        /* 187 */
+       OP_DUMP,        /* 188 */
+       OP_GOTO,        /* 189 */
+       OP_EXIT,        /* 190 */
+       OP_OPEN,        /* 191 */
+       OP_CLOSE,       /* 192 */
+       OP_PIPE_OP,     /* 193 */
+       OP_FILENO,      /* 194 */
+       OP_UMASK,       /* 195 */
+       OP_BINMODE,     /* 196 */
+       OP_TIE,         /* 197 */
+       OP_UNTIE,       /* 198 */
+       OP_TIED,        /* 199 */
+       OP_DBMOPEN,     /* 200 */
+       OP_DBMCLOSE,    /* 201 */
+       OP_SSELECT,     /* 202 */
+       OP_SELECT,      /* 203 */
+       OP_GETC,        /* 204 */
+       OP_READ,        /* 205 */
+       OP_ENTERWRITE,  /* 206 */
+       OP_LEAVEWRITE,  /* 207 */
+       OP_PRTF,        /* 208 */
+       OP_PRINT,       /* 209 */
+       OP_SYSOPEN,     /* 210 */
+       OP_SYSSEEK,     /* 211 */
+       OP_SYSREAD,     /* 212 */
+       OP_SYSWRITE,    /* 213 */
+       OP_SEND,        /* 214 */
+       OP_RECV,        /* 215 */
+       OP_EOF,         /* 216 */
+       OP_TELL,        /* 217 */
+       OP_SEEK,        /* 218 */
+       OP_TRUNCATE,    /* 219 */
+       OP_FCNTL,       /* 220 */
+       OP_IOCTL,       /* 221 */
+       OP_FLOCK,       /* 222 */
+       OP_SOCKET,      /* 223 */
+       OP_SOCKPAIR,    /* 224 */
+       OP_BIND,        /* 225 */
+       OP_CONNECT,     /* 226 */
+       OP_LISTEN,      /* 227 */
+       OP_ACCEPT,      /* 228 */
+       OP_SHUTDOWN,    /* 229 */
+       OP_GSOCKOPT,    /* 230 */
+       OP_SSOCKOPT,    /* 231 */
+       OP_GETSOCKNAME, /* 232 */
+       OP_GETPEERNAME, /* 233 */
+       OP_LSTAT,       /* 234 */
+       OP_STAT,        /* 235 */
+       OP_FTRREAD,     /* 236 */
+       OP_FTRWRITE,    /* 237 */
+       OP_FTREXEC,     /* 238 */
+       OP_FTEREAD,     /* 239 */
+       OP_FTEWRITE,    /* 240 */
+       OP_FTEEXEC,     /* 241 */
+       OP_FTIS,        /* 242 */
+       OP_FTEOWNED,    /* 243 */
+       OP_FTROWNED,    /* 244 */
+       OP_FTZERO,      /* 245 */
+       OP_FTSIZE,      /* 246 */
+       OP_FTMTIME,     /* 247 */
+       OP_FTATIME,     /* 248 */
+       OP_FTCTIME,     /* 249 */
+       OP_FTSOCK,      /* 250 */
+       OP_FTCHR,       /* 251 */
+       OP_FTBLK,       /* 252 */
+       OP_FTFILE,      /* 253 */
+       OP_FTDIR,       /* 254 */
+       OP_FTPIPE,      /* 255 */
+       OP_FTLINK,      /* 256 */
+       OP_FTSUID,      /* 257 */
+       OP_FTSGID,      /* 258 */
+       OP_FTSVTX,      /* 259 */
+       OP_FTTTY,       /* 260 */
+       OP_FTTEXT,      /* 261 */
+       OP_FTBINARY,    /* 262 */
+       OP_CHDIR,       /* 263 */
+       OP_CHOWN,       /* 264 */
+       OP_CHROOT,      /* 265 */
+       OP_UNLINK,      /* 266 */
+       OP_CHMOD,       /* 267 */
+       OP_UTIME,       /* 268 */
+       OP_RENAME,      /* 269 */
+       OP_LINK,        /* 270 */
+       OP_SYMLINK,     /* 271 */
+       OP_READLINK,    /* 272 */
+       OP_MKDIR,       /* 273 */
+       OP_RMDIR,       /* 274 */
+       OP_OPEN_DIR,    /* 275 */
+       OP_READDIR,     /* 276 */
+       OP_TELLDIR,     /* 277 */
+       OP_SEEKDIR,     /* 278 */
+       OP_REWINDDIR,   /* 279 */
+       OP_CLOSEDIR,    /* 280 */
+       OP_FORK,        /* 281 */
+       OP_WAIT,        /* 282 */
+       OP_WAITPID,     /* 283 */
+       OP_SYSTEM,      /* 284 */
+       OP_EXEC,        /* 285 */
+       OP_KILL,        /* 286 */
+       OP_GETPPID,     /* 287 */
+       OP_GETPGRP,     /* 288 */
+       OP_SETPGRP,     /* 289 */
+       OP_GETPRIORITY, /* 290 */
+       OP_SETPRIORITY, /* 291 */
+       OP_TIME,        /* 292 */
+       OP_TMS,         /* 293 */
+       OP_LOCALTIME,   /* 294 */
+       OP_GMTIME,      /* 295 */
+       OP_ALARM,       /* 296 */
+       OP_SLEEP,       /* 297 */
+       OP_SHMGET,      /* 298 */
+       OP_SHMCTL,      /* 299 */
+       OP_SHMREAD,     /* 300 */
+       OP_SHMWRITE,    /* 301 */
+       OP_MSGGET,      /* 302 */
+       OP_MSGCTL,      /* 303 */
+       OP_MSGSND,      /* 304 */
+       OP_MSGRCV,      /* 305 */
+       OP_SEMGET,      /* 306 */
+       OP_SEMCTL,      /* 307 */
+       OP_SEMOP,       /* 308 */
+       OP_REQUIRE,     /* 309 */
+       OP_DOFILE,      /* 310 */
+       OP_ENTEREVAL,   /* 311 */
+       OP_LEAVEEVAL,   /* 312 */
+       OP_ENTERTRY,    /* 313 */
+       OP_LEAVETRY,    /* 314 */
+       OP_GHBYNAME,    /* 315 */
+       OP_GHBYADDR,    /* 316 */
+       OP_GHOSTENT,    /* 317 */
+       OP_GNBYNAME,    /* 318 */
+       OP_GNBYADDR,    /* 319 */
+       OP_GNETENT,     /* 320 */
+       OP_GPBYNAME,    /* 321 */
+       OP_GPBYNUMBER,  /* 322 */
+       OP_GPROTOENT,   /* 323 */
+       OP_GSBYNAME,    /* 324 */
+       OP_GSBYPORT,    /* 325 */
+       OP_GSERVENT,    /* 326 */
+       OP_SHOSTENT,    /* 327 */
+       OP_SNETENT,     /* 328 */
+       OP_SPROTOENT,   /* 329 */
+       OP_SSERVENT,    /* 330 */
+       OP_EHOSTENT,    /* 331 */
+       OP_ENETENT,     /* 332 */
+       OP_EPROTOENT,   /* 333 */
+       OP_ESERVENT,    /* 334 */
+       OP_GPWNAM,      /* 335 */
+       OP_GPWUID,      /* 336 */
+       OP_GPWENT,      /* 337 */
+       OP_SPWENT,      /* 338 */
+       OP_EPWENT,      /* 339 */
+       OP_GGRNAM,      /* 340 */
+       OP_GGRGID,      /* 341 */
+       OP_GGRENT,      /* 342 */
+       OP_SGRENT,      /* 343 */
+       OP_EGRENT,      /* 344 */
+       OP_GETLOGIN,    /* 345 */
+       OP_SYSCALL,     /* 346 */
+       OP_LOCK,        /* 347 */
+       OP_THREADSV,    /* 348 */
+       OP_SETSTATE,    /* 349 */
+       OP_METHOD_NAMED,/* 350 */
        OP_max          
 } opcode;
 
-#define MAXO 350
+#define MAXO 351
 
index 1945146..6860b18 100644 (file)
--- a/perlapi.c
+++ b/perlapi.c
@@ -6304,6 +6304,13 @@ Perl_pp_leavesub(pTHXo)
     return ((CPerlObj*)pPerl)->Perl_pp_leavesub();
 }
 
+#undef  Perl_pp_leavesublv
+OP *
+Perl_pp_leavesublv(pTHXo)
+{
+    return ((CPerlObj*)pPerl)->Perl_pp_leavesublv();
+}
+
 #undef  Perl_pp_leavetry
 OP *
 Perl_pp_leavetry(pTHXo)
index 60a901e..10808ff 100644 (file)
@@ -866,6 +866,11 @@ to exist.
 (F) You aren't allowed to assign to the item indicated, or otherwise try to
 change it, such as with an auto-increment.
 
+=item Can't modify non-lvalue subroutine call
+
+(F) Subroutines used in lvalue context should be marked as such, see
+L<perlsub/"Lvalue subroutines">.
+
 =item Can't modify nonexistent substring
 
 (P) The internal routine that does assignment to a substr() was handed
@@ -950,6 +955,12 @@ of suidperl.
 (F) The return statement was executed in mainline code, that is, where
 there was no subroutine call to return out of.  See L<perlsub>.
 
+=item Can't return %s from lvalue subroutine
+
+(F) Perl detected an attempt to return illegal lvalues (such
+as temporary or readonly values) from a subroutine used as an lvalue.
+This is not allowed.
+
 =item Can't stat script "%s"
 
 (P) For some reason you can't fstat() the script even though you have
@@ -1713,6 +1724,12 @@ effective uids or gids failed.
 (W) You tried to do a listen on a closed socket.  Did you forget to check
 the return value of your socket() call?  See L<perlfunc/listen>.
 
+=item Lvalue subs returning %s not implemented yet
+
+(F) Due to limitations in the current implementation, array and hash
+values cannot be returned in subroutines used in lvalue context.
+See L<perlsub/"Lvalue subroutines">.
+
 =item Method for operation %s not found in package %s during blessing
 
 (F) An attempt was made to specify an entry in an overloading table that
index 47f507f..2beb3de 100644 (file)
@@ -611,6 +611,45 @@ Perl will print
 The behavior of local() on non-existent members of composite
 types is subject to change in future.
 
+=head2 Lvalue subroutines
+
+B<WARNING>: Lvalue subroutines are still experimental and the implementation
+may change in future versions of Perl.
+
+It is possible to return a modifiable value from a subroutine.
+To do this, you have to declare the subroutine to return an lvalue.
+
+    my $val;
+    sub canmod : lvalue {
+       $val;
+    }
+    sub nomod {
+       $val;
+    }
+
+    canmod() = 5;   # assigns to $val
+    nomod()  = 5;   # ERROR
+
+The scalar/list context for the subroutine and for the right-hand
+side of assignment is determined as if the subroutine call is replaced
+by a scalar. For example, consider:
+
+    data(2,3) = get_data(3,4);
+
+Both subroutines here are called in a scalar context, while in:
+
+    (data(2,3)) = get_data(3,4);
+
+and in:
+
+    (data(2),data(3)) = get_data(3,4);
+
+all the subroutines are called in a list context.
+
+The current implementation does not allow arrays and hashes to be
+returned from lvalue subroutines directly.  You may return a
+reference instead.  This restriction may be lifted in future.
+
 =head2 Passing Symbol Table Entries (typeglobs)
 
 B<WARNING>: The mechanism described in this section was originally
diff --git a/pp.c b/pp.c
index cde539c..4d96370 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -375,6 +375,8 @@ PP(pp_rv2cv)
     if (cv) {
        if (CvCLONE(cv))
            cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+       if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
+           Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call");
     }
     else
        cv = (CV*)&PL_sv_undef;
diff --git a/pp.sym b/pp.sym
index cbbbaae..c0a8e91 100644 (file)
--- a/pp.sym
+++ b/pp.sym
@@ -203,6 +203,7 @@ Perl_pp_orassign
 Perl_pp_method
 Perl_pp_entersub
 Perl_pp_leavesub
+Perl_pp_leavesublv
 Perl_pp_caller
 Perl_pp_warn
 Perl_pp_die
index 78f07a1..bb034e5 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1921,13 +1921,16 @@ PP(pp_leavesub)
                    *MARK = SvREFCNT_inc(TOPs);
                    FREETMPS;
                    sv_2mortal(*MARK);
-               } else {
+               }
+               else {
                    FREETMPS;
                    *MARK = sv_mortalcopy(TOPs);
                }
-           } else
+           }
+           else
                *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
-       } else {
+       }
+       else {
            MEXTEND(MARK, 0);
            *MARK = &PL_sv_undef;
        }
@@ -1950,6 +1953,138 @@ PP(pp_leavesub)
     return pop_return();
 }
 
+/* This duplicates the above code because the above code must not
+ * get any slower by more conditions */
+PP(pp_leavesublv)
+{
+    djSP;
+    SV **mark;
+    SV **newsp;
+    PMOP *newpm;
+    I32 gimme;
+    register PERL_CONTEXT *cx;
+    struct block_sub cxsub;
+
+    POPBLOCK(cx,newpm);
+    POPSUB1(cx);       /* Delay POPSUB2 until stack values are safe */
+    TAINT_NOT;
+
+    if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
+       /* We are an argument to a function or grep().
+        * This kind of lvalueness was legal before lvalue
+        * subroutines too, so be backward compatible:
+        * cannot report errors.  */
+
+       /* Scalar context *is* possible, on the LHS of -> only,
+        * as in f()->meth().  But this is not an lvalue. */
+       if (gimme == G_SCALAR)
+           goto temporise;
+       if (gimme == G_ARRAY) {
+           if (!CvLVALUE(cxsub.cv))
+               goto temporise_array;
+           EXTEND_MORTAL(SP - newsp);
+           for (mark = newsp + 1; mark <= SP; mark++) {
+               if (SvTEMP(*mark))
+                   /* empty */ ;
+               else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
+                   *mark = sv_mortalcopy(*mark);
+               else {
+                   /* Can be a localized value subject to deletion. */
+                   PL_tmps_stack[++PL_tmps_ix] = *mark;
+                   SvREFCNT_inc(*mark);
+               }
+           }
+       }
+    }
+    else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
+       /* Here we go for robustness, not for speed, so we change all
+        * the refcounts so the caller gets a live guy. Cannot set
+        * TEMP, so sv_2mortal is out of question. */
+       if (!CvLVALUE(cxsub.cv))
+           Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call");
+       if (gimme == G_SCALAR) {
+           MARK = newsp + 1;
+           EXTEND_MORTAL(1);
+           if (MARK == SP) {
+               if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY))
+                   Perl_croak(aTHX_ "Can't return a %s from lvalue subroutine",
+                       SvREADONLY(TOPs) ? "readonly value" : "temporary");
+               else {                  /* Can be a localized value
+                                        * subject to deletion. */
+                   PL_tmps_stack[++PL_tmps_ix] = *mark;
+                   SvREFCNT_inc(*mark);
+               }
+           }
+           else                        /* Should not happen? */
+               Perl_croak(aTHX_ "%s returned from lvalue subroutine in scalar context",
+                   (MARK > SP ? "Empty array" : "Array"));
+           SP = MARK;
+       }
+       else if (gimme == G_ARRAY) {
+           EXTEND_MORTAL(SP - newsp);
+           for (mark = newsp + 1; mark <= SP; mark++) {
+               if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY))
+               /* Might be flattened array after $#array =  */
+               Perl_croak(aTHX_ "Can't return %s from lvalue subroutine",
+                       (*mark != &PL_sv_undef)
+                       ? (SvREADONLY(TOPs)
+                           ? "a readonly value" : "a temporary")
+                       : "an uninitialized value");
+               else {
+                   mortalize:
+                   /* Can be a localized value subject to deletion. */
+                   PL_tmps_stack[++PL_tmps_ix] = *mark;
+                   SvREFCNT_inc(*mark);
+               }
+           }
+       }
+    }
+    else {
+       if (gimme == G_SCALAR) {
+         temporise:
+           MARK = newsp + 1;
+           if (MARK <= SP) {
+               if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
+                   if (SvTEMP(TOPs)) {
+                       *MARK = SvREFCNT_inc(TOPs);
+                       FREETMPS;
+                       sv_2mortal(*MARK);
+                   }
+                   else {
+                       FREETMPS;
+                       *MARK = sv_mortalcopy(TOPs);
+                   }
+               }
+               else
+                   *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
+           }
+           else {
+               MEXTEND(MARK, 0);
+               *MARK = &PL_sv_undef;
+           }
+           SP = MARK;
+       }
+       else if (gimme == G_ARRAY) {
+         temporise_array:
+           for (MARK = newsp + 1; MARK <= SP; MARK++) {
+               if (!SvTEMP(*MARK)) {
+                   *MARK = sv_mortalcopy(*MARK);
+                   TAINT_NOT;  /* Each item is independent */
+               }
+           }
+       }
+    }
+    PUTBACK;
+    
+    POPSUB2();         /* Stack values are safe: release CV and @_ ... */
+    PL_curpm = newpm;  /* ... and pop $1 et al */
+
+    LEAVE;
+    return pop_return();
+}
+
+
 STATIC CV *
 S_get_db_sub(pTHX_ SV **svp, CV *cv)
 {
@@ -2193,7 +2328,8 @@ try_autoload:
                            "entersub: %p grabbing %p:%s in stash %s\n",
                            thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
                                HvNAME(CvSTASH(cv)) : "(none)"));
-           } else {
+           }
+           else {
                /* Make a new clone. */
                CV *clonecv;
                SvREFCNT_inc(cv); /* don't let it vanish from under us */
index 5c3d301..44f1658 100644 (file)
@@ -204,6 +204,7 @@ PERL_PPDEF(Perl_pp_orassign)
 PERL_PPDEF(Perl_pp_method)
 PERL_PPDEF(Perl_pp_entersub)
 PERL_PPDEF(Perl_pp_leavesub)
+PERL_PPDEF(Perl_pp_leavesublv)
 PERL_PPDEF(Perl_pp_caller)
 PERL_PPDEF(Perl_pp_warn)
 PERL_PPDEF(Perl_pp_die)
diff --git a/t/pragma/sub_lval.t b/t/pragma/sub_lval.t
new file mode 100755 (executable)
index 0000000..f6d867c
--- /dev/null
@@ -0,0 +1,429 @@
+print "1..46\n";
+
+BEGIN {
+    chdir 't' if -d 't';
+    unshift @INC, '../lib';
+}
+
+sub a {use attrs 'lvalue'; my $a = 34; bless \$a}  # Return a temporary
+sub b {use attrs 'lvalue'; shift}
+
+my $out = a(b());              # Check that temporaries are allowed.
+print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error.
+print "ok 1\n";
+
+my @out = grep /main/, a(b()); # Check that temporaries are allowed.
+print "# `@out'\nnot " unless @out==1; # Not reached if error.
+print "ok 2\n";
+
+my $in;
+
+# Check that we can return localized values from subroutines:
+
+sub in {use attrs 'lvalue'; $in = shift;}
+sub neg {use attrs 'lvalue';  #(num_str) return num_str
+    local $_ = shift;
+    s/^\+/-/;
+    $_;
+}
+in(neg("+2"));
+
+
+print "# `$in'\nnot " unless $in eq '-2';
+print "ok 3\n";
+
+sub get_lex {use attrs 'lvalue'; $in}
+sub get_st {use attrs 'lvalue'; $blah}
+sub id {use attrs 'lvalue'; shift}
+sub id1 {use attrs 'lvalue'; $_[0]}
+sub inc {use attrs 'lvalue'; ++$_[0]}
+
+$in = 5;
+$blah = 3;
+
+get_st = 7;
+
+print "# `$blah' ne 7\nnot " unless $blah eq 7;
+print "ok 4\n";
+
+get_lex = 7;
+
+print "# `$in' ne 7\nnot " unless $in eq 7;
+print "ok 5\n";
+
+++get_st;
+
+print "# `$blah' ne 8\nnot " unless $blah eq 8;
+print "ok 6\n";
+
+++get_lex;
+
+print "# `$in' ne 8\nnot " unless $in eq 8;
+print "ok 7\n";
+
+id(get_st) = 10;
+
+print "# `$blah' ne 10\nnot " unless $blah eq 10;
+print "ok 8\n";
+
+id(get_lex) = 10;
+
+print "# `$in' ne 10\nnot " unless $in eq 10;
+print "ok 9\n";
+
+++id(get_st);
+
+print "# `$blah' ne 11\nnot " unless $blah eq 11;
+print "ok 10\n";
+
+++id(get_lex);
+
+print "# `$in' ne 11\nnot " unless $in eq 11;
+print "ok 11\n";
+
+id1(get_st) = 20;
+
+print "# `$blah' ne 20\nnot " unless $blah eq 20;
+print "ok 12\n";
+
+id1(get_lex) = 20;
+
+print "# `$in' ne 20\nnot " unless $in eq 20;
+print "ok 13\n";
+
+++id1(get_st);
+
+print "# `$blah' ne 21\nnot " unless $blah eq 21;
+print "ok 14\n";
+
+++id1(get_lex);
+
+print "# `$in' ne 21\nnot " unless $in eq 21;
+print "ok 15\n";
+
+inc(get_st);
+
+print "# `$blah' ne 22\nnot " unless $blah eq 22;
+print "ok 16\n";
+
+inc(get_lex);
+
+print "# `$in' ne 22\nnot " unless $in eq 22;
+print "ok 17\n";
+
+inc(id(get_st));
+
+print "# `$blah' ne 23\nnot " unless $blah eq 23;
+print "ok 18\n";
+
+inc(id(get_lex));
+
+print "# `$in' ne 23\nnot " unless $in eq 23;
+print "ok 19\n";
+
+++inc(id1(id(get_st)));
+
+print "# `$blah' ne 25\nnot " unless $blah eq 25;
+print "ok 20\n";
+
+++inc(id1(id(get_lex)));
+
+print "# `$in' ne 25\nnot " unless $in eq 25;
+print "ok 21\n";
+
+@a = (1) x 3;
+@b = (undef) x 2;
+$#c = 3;                       # These slots are not fillable.
+
+# Explanation: empty slots contain &sv_undef.
+
+=for disabled constructs
+
+sub a3 {use attrs 'lvalue'; @a}
+sub b2 {use attrs 'lvalue'; @b}
+sub c4 {use attrs 'lvalue'; @c}
+
+$_ = '';
+
+eval <<'EOE' or $_ = $@;
+  ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78);
+  1;
+EOE
+
+#@out = ($x, a3, $y, b2, $z, c4, $t);
+#@in = (34 .. 41, (undef) x 4, 46);
+#print "# `@out' ne `@in'\nnot " unless "@out" eq "@in";
+
+print "# '$_'.\nnot "
+  unless /Can\'t return an uninitialized value from lvalue subroutine/;
+=cut
+
+print "ok 22\n";
+
+my $var;
+
+sub a::var {use attrs 'lvalue'; $var}
+
+"a"->var = 45;
+
+print "# `$var' ne 45\nnot " unless $var eq 45;
+print "ok 23\n";
+
+my $oo;
+$o = bless \$oo, "a";
+
+$o->var = 47;
+
+print "# `$var' ne 47\nnot " unless $var eq 47;
+print "ok 24\n";
+
+sub o {use attrs 'lvalue'; $o}
+
+o->var = 49;
+
+print "# `$var' ne 49\nnot " unless $var eq 49;
+print "ok 25\n";
+
+sub nolv () { $x0, $x1 } # Not lvalue
+
+$_ = '';
+
+eval <<'EOE' or $_ = $@;
+  nolv = (2,3);
+  1;
+EOE
+
+print "not "
+  unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
+print "ok 26\n";
+
+$_ = '';
+
+eval <<'EOE' or $_ = $@;
+  nolv = (2,3) if $_;
+  1;
+EOE
+
+print "not "
+  unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
+print "ok 27\n";
+
+$_ = '';
+
+eval <<'EOE' or $_ = $@;
+  &nolv = (2,3) if $_;
+  1;
+EOE
+
+print "not "
+  unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
+print "ok 28\n";
+
+$x0 = $x1 = $_ = undef;
+$nolv = \&nolv;
+
+eval <<'EOE' or $_ = $@;
+  $nolv->() = (2,3) if $_;
+  1;
+EOE
+
+print "# '$_', '$x0', '$x1'.\nnot " if defined $_;
+print "ok 29\n";
+
+$x0 = $x1 = $_ = undef;
+$nolv = \&nolv;
+
+eval <<'EOE' or $_ = $@;
+  $nolv->() = (2,3);
+  1;
+EOE
+
+print "# '$_', '$x0', '$x1'.\nnot "
+  unless /Can\'t modify non-lvalue indirect subroutine call/;
+print "ok 30\n";
+
+sub lv0 {use attrs 'lvalue';}          # Converted to lv10 in scalar context
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  lv0 = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t return a readonly value from lvalue subroutine/;
+print "ok 31\n";
+
+sub lv10 {use attrs 'lvalue';}
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  (lv0) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot " if defined $_;
+print "ok 32\n";
+
+sub lv1u {use attrs 'lvalue'; undef }
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  lv1u = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t return a readonly value from lvalue subroutine/;
+print "ok 33\n";
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  (lv1u) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t return an uninitialized value from lvalue subroutine/;
+print "ok 34\n";
+
+$x = '1234567';
+sub lv1t {use attrs 'lvalue'; index $x, 2 }
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  lv1t = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t return a temporary from lvalue subroutine/;
+print "ok 35\n";
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  (lv1t) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t return a temporary from lvalue subroutine/;
+print "ok 36\n";
+
+$xxx = 'xxx';
+sub xxx () { $xxx }  # Not lvalue
+sub lv1tmp {use attrs 'lvalue'; xxx }                  # is it a TEMP?
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  lv1tmp = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t return a temporary from lvalue subroutine/;
+print "ok 37\n";
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  (lv1tmp) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t return a temporary from lvalue subroutine/;
+print "ok 38\n";
+
+sub xxx () { 'xxx' } # Not lvalue
+sub lv1tmpr {use attrs 'lvalue'; xxx }                 # is it a TEMP?
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  lv1tmpr = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t return a readonly value from lvalue subroutine/;
+print "ok 39\n";
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  (lv1tmpr) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t return a readonly value from lvalue subroutine/;
+print "ok 40\n";
+
+=for disabled constructs
+
+sub lva {use attrs 'lvalue';@a}
+
+$_ = undef;
+@a = ();
+$a[1] = 12;
+eval <<'EOE' or $_ = $@;
+  (lva) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot "
+  unless /Can\'t return an uninitialized value from lvalue subroutine/;
+print "ok 41\n";
+
+$_ = undef;
+@a = ();
+$a[0] = undef;
+$a[1] = 12;
+eval <<'EOE' or $_ = $@;
+  (lva) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
+print "ok 42\n";
+
+$_ = undef;
+@a = ();
+$a[0] = undef;
+$a[1] = 12;
+eval <<'EOE' or $_ = $@;
+  (lva) = (2,3);
+  1;
+EOE
+
+print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
+print "ok 43\n";
+
+=cut
+
+print "ok $_\n" for 41..43;
+
+sub lv1n {use attrs 'lvalue'; $newvar }
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  lv1n = (3,4);
+  1;
+EOE
+
+print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' ";
+print "ok 44\n";
+
+sub lv1nn {use attrs 'lvalue'; $nnewvar }
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+  (lv1nn) = (3,4);
+  1;
+EOE
+
+print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' ";
+print "ok 45\n";
+
+$a = \&lv1nn;
+$a->() = 8;
+print "# '$nnewvar'.\nnot " unless $nnewvar eq '8';
+print "ok 46\n";
index 5e0dd27..70e6d60 100644 (file)
     Deep recursion on subroutine \"%s\"
        sub fred
        {
-       goto &fred() if $a++ < 200
+         fred() if $a++ < 200
        }
         
-       goto &fred()
+       fred()
 
       (in cleanup) foo bar
        package Foo;
@@ -179,10 +179,10 @@ use warnings 'recursion' ;
 BEGIN { warn "PREFIX\n" ;}
 sub fred
 {
-    goto &fred() if $a++ < 200
+    fred() if $a++ < 200
 }
  
-goto &fred()
+fred()
 EXPECT
 Deep recursion on subroutine "main::fred" at - line 6.
 ########
@@ -191,12 +191,11 @@ no warnings 'recursion' ;
 BEGIN { warn "PREFIX\n" ;}
 sub fred
 {
-    goto &fred() if $a++ < 200
+    fred() if $a++ < 200
 }
  
-goto &fred()
+fred()
 EXPECT
-Can't find label
 ########
 # pp_ctl.c
 use warnings 'unsafe' ;