develooper Front page | perl.perl5.porters | Postings from January 2001

[PATCH] sub foo : lvalue {return $a}

From:
Simon Cozens
Date:
January 2, 2001 09:00
Subject:
[PATCH] sub foo : lvalue {return $a}
Message ID:
20010102165759.A22109@deep-dark-truthful-mirror.perlhacker.org
pp_return puts stuff onto the stack in much the same way that
pp_leavesub and pp_leavesublv does, but obviously, pp_return
doesn't deal with the lvalue case, so the code in the subject
line doesn't do the right thing. Here I've abstracted out the
lvalue-sub return handling into another function, which is called
by both pp_leavesublv and pp_return, so you can now use return()
on your lvalue subs.


--- pp_hot.c~	Tue Jan  2 15:22:57 2001
+++ pp_hot.c	Tue Jan  2 16:55:07 2001
@@ -2206,67 +2206,31 @@ PP(pp_leavesublv)
 	}
     }
     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(cx->blk_sub.cv)) {
+        I32 why = do_leave_lv();
+        SPAGAIN;
+	if (why <0) {
 	    POPSUB(cx,sv);
 	    PL_curpm = newpm;
 	    LEAVE;
 	    LEAVESUB(sv);
-	    DIE(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)) {
-		    POPSUB(cx,sv);
-		    PL_curpm = newpm;
-		    LEAVE;
-		    LEAVESUB(sv);
+            switch (why) {
+                case -1:
+                    DIE(aTHX_ "Can't modify non-lvalue subroutine call");
+                case -2:
+                    DIE(aTHX_ "Empty array return from lvalue subroutine in scalar context");
+                case -3:
+                    DIE(aTHX_ "Array return from lvalue subroutine in scalar context");
+                case -4:
 		    DIE(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;
-		    (void)SvREFCNT_inc(*mark);
-		}
-	    }
-	    else {			/* Should not happen? */
-		POPSUB(cx,sv);
-		PL_curpm = newpm;
-		LEAVE;
-		LEAVESUB(sv);
-		DIE(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 =  */
-		    PUTBACK;
-		    POPSUB(cx,sv);
-		    PL_curpm = newpm;
-		    LEAVE;
-		    LEAVESUB(sv);
-		    DIE(aTHX_ "Can't return %s from lvalue subroutine",
-			(*mark != &PL_sv_undef)
-			? (SvREADONLY(TOPs)
-			    ? "a readonly value" : "a temporary")
-			: "an uninitialized value");
-		}
-		else {
-		    /* Can be a localized value subject to deletion. */
-		    PL_tmps_stack[++PL_tmps_ix] = *mark;
-		    (void)SvREFCNT_inc(*mark);
-		}
-	    }
-	}
+                case -5:
+                case -6:
+                case -7:
+                    DIE(aTHX_ "Can't return %s from lvalue subroutine", why == -5 ? "a readonly value" : (why == -6 ? "a temporary" : "an uninitialized value"));
+
+            }
+    } else
+        mark = PL_stack_base + why;
     }
     else {
 	if (gimme == G_SCALAR) {
@@ -2304,8 +2268,8 @@ PP(pp_leavesublv)
 		}
 	    }
 	}
+        PUTBACK;
     }
-    PUTBACK;
 
     POPSUB(cx,sv);	/* Stack values are safe: release CV and @_ ... */
     PL_curpm = newpm;	/* ... and pop $1 et al */
--- pp_ctl.c~	Tue Jan  2 14:57:50 2001
+++ pp_ctl.c	Tue Jan  2 16:55:23 2001
@@ -1947,7 +1947,37 @@ PP(pp_return)
     if (gimme == G_SCALAR) {
 	if (MARK < SP) {
 	    if (popsub2) {
-		if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
+                if (cx->blk_sub.lval && CvLVALUE(cx->blk_sub.cv)) {
+                   I32 why;
+                   PUSHMARK(mark);
+                   why = do_leave_lv();
+                   SPAGAIN;
+                   if (why <0) {
+                       POPSUB(cx,sv);
+                       PL_curpm = newpm;
+                       LEAVE;
+                       LEAVESUB(sv);
+                       switch (why) {
+                           case -1:
+                               DIE(aTHX_ "Can't modify non-lvalue subroutine call");
+                           case -2:
+                               DIE(aTHX_ "Empty array return from lvalue subroutine in scalar context");
+                           case -3:
+                               DIE(aTHX_ "Array return from lvalue subroutine in scalar context");
+                           case -4:
+                                DIE(aTHX_ "Can't return a %s from lvalue subroutine",
+                                SvREADONLY(TOPs) ? "readonly value" : "temporary");
+                           case -5:
+                           case -6:
+                           case -7:
+                                DIE(aTHX_ "Can't return %s from lvalue subroutine", why == -5 ? "a readonly value" : (why == -6 ? "a temporary" : "an uninitialized value"));
+                       }
+                    } else {
+                        mark = PL_stack_base + why;
+                        newsp = sp;
+                    }
+                }
+                else if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
 		    if (SvTEMP(TOPs)) {
 			*++newsp = SvREFCNT_inc(*SP);
 			FREETMPS;
@@ -4432,3 +4462,52 @@ sv_cmp_static(pTHXo_ register SV *str1, 
 }
 
 #endif /* PERL_OBJECT */
+
+I32
+Perl_do_leave_lv()
+{
+    /* Do this all manually... */
+    dSP;
+    PERL_CONTEXT *cx  = &cxstack[cxstack_ix+1];
+    SV** mark         = PL_stack_base + *PL_markstack_ptr;
+    I32 gimme         = cx->blk_gimme;
+    SV** newsp        = PL_stack_base + cx->blk_oldsp;
+
+    /* 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(cx->blk_sub.cv))
+        return -1;
+    
+    if (gimme == G_SCALAR) {
+        MARK = newsp+1;
+        EXTEND_MORTAL(1);
+        if (MARK != SP) /* Probably can't happen */
+            return MARK > SP ? -2 : -3;
+
+        /* Can't return a temp */
+        if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY))
+            return -4;
+
+        /* Can be a localized value subject to  deletion. */ 
+        PL_tmps_stack[++PL_tmps_ix] = *mark;
+        (void)SvREFCNT_inc(*mark);
+        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))
+                return 
+                    (*mark != &PL_sv_undef) ? (SvREADONLY(TOPs) ? -5 : -6) : -7;
+            /* Can be a localized value subject to deletion. */
+            PL_tmps_stack[++PL_tmps_ix] = *mark;
+            (void)SvREFCNT_inc(*mark);
+        }
+    }
+    PUTBACK;
+    return(mark - PL_stack_base);
+}
+
+
+    
--- embed.pl~	Tue Jan  2 15:36:05 2001
+++ embed.pl	Tue Jan  2 16:30:11 2001
@@ -1489,6 +1489,7 @@ p	|I32	|do_shmio	|I32 optype|SV** mark|S
 #endif
 Ap	|void	|do_join	|SV* sv|SV* del|SV** mark|SV** sp
 p	|OP*	|do_kv
+p	|I32	|do_leave_lv	
 Ap	|bool	|do_open	|GV* gv|char* name|I32 len|int as_raw \
 				|int rawmode|int rawperm|PerlIO* supplied_fp
 Ap	|bool	|do_open9	|GV *gv|char *name|I32 len|int as_raw \
--- t/pragma/sub_lval.t~	Tue Jan  2 16:39:01 2001
+++ t/pragma/sub_lval.t	Tue Jan  2 16:51:04 2001
@@ -1,4 +1,4 @@
-print "1..49\n";
+print "1..50\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -448,3 +448,10 @@ open bar, ">nothing" or die $!; 
 bar = *STDOUT;
 print bar "ok 49\n";
 unlink "nothing";
+
+sub baz : lvalue {
+    return $a;
+}
+$a = "not ok 50\n";
+baz() = "ok 50\n";
+print $a;

-- 
"A word to the wise: a credentials dicksize war is usually a bad idea on the
net."
(David Parsons in c.o.l.development.system, about coding in C.)



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About