From: Gurusamy Sarathy <gsar@cpan.org>
Date: Sun, 5 Sep 1999 22:07:18 +0000 (+0000)
Subject: initial implementation of lvalue subroutines (slightly fixed
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cd06dffe59d60ee6a2fdd7c81f8cef42c7026b36;p=p5sagit%2Fp5-mst-13.2.git

initial implementation of lvalue subroutines (slightly fixed
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
---

diff --git a/MANIFEST b/MANIFEST
index f5ea95c..6bd774f 100644
--- 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
--- 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
--- 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
--- 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
--- a/embed.h
+++ b/embed.h
@@ -1212,6 +1212,7 @@
 #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
@@ -2538,6 +2539,7 @@
 #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)
@@ -4959,6 +4961,8 @@
 #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
diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
index 38c8e65..ff3899f 100644
--- a/ext/Opcode/Opcode.pm
+++ b/ext/Opcode/Opcode.pm
@@ -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
 
diff --git a/ext/attrs/attrs.pm b/ext/attrs/attrs.pm
index fe2bf35..e97fa1e 100644
--- a/ext/attrs/attrs.pm
+++ b/ext/attrs/attrs.pm
@@ -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
diff --git a/ext/attrs/attrs.xs b/ext/attrs/attrs.xs
index 53ba535..a92922d 100644
--- a/ext/attrs/attrs.xs
+++ b/ext/attrs/attrs.xs
@@ -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;
 }
diff --git a/objXSUB.h b/objXSUB.h
index e7b34b1..abb9f39 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -4406,6 +4406,10 @@
 #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
--- 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
--- 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 */
diff --git a/opcode.h b/opcode.h
index abd180c..7ca8d48 100644
--- 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 */
diff --git a/opcode.pl b/opcode.pl
index f112745..5b666d3 100755
--- 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
diff --git a/opnames.h b/opnames.h
index 417d74d..e9f8b4f 100644
--- 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
 
diff --git a/perlapi.c b/perlapi.c
index 1945146..6860b18 100644
--- 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)
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 60a901e..10808ff 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -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
diff --git a/pod/perlsub.pod b/pod/perlsub.pod
index 47f507f..2beb3de 100644
--- a/pod/perlsub.pod
+++ b/pod/perlsub.pod
@@ -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
--- 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
--- 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
diff --git a/pp_hot.c b/pp_hot.c
index 78f07a1..bb034e5 100644
--- 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 */
diff --git a/pp_proto.h b/pp_proto.h
index 5c3d301..44f1658 100644
--- a/pp_proto.h
+++ b/pp_proto.h
@@ -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
index 0000000..f6d867c
--- /dev/null
+++ b/t/pragma/sub_lval.t
@@ -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";
diff --git a/t/pragma/warn/pp_ctl b/t/pragma/warn/pp_ctl
index 5e0dd27..70e6d60 100644
--- a/t/pragma/warn/pp_ctl
+++ b/t/pragma/warn/pp_ctl
@@ -48,10 +48,10 @@
     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' ;