From: Nicholas Clark <nick@ccl4.org>
Date: Thu, 6 Sep 2007 09:18:41 +0000 (+0000)
Subject: Make state $zok = slosh(); behave as the Perl 6 design with an implicit
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c5917253cfa0ec36b4c868a1582baaaab99eb0d0;p=p5sagit%2Fp5-mst-13.2.git
Make state $zok = slosh(); behave as the Perl 6 design with an implicit
START block. First time through, call slosh() and assign to $zok.
Subsequently neither call slosh() nor assign to $zok. Adds a new op
ONCE to control the conditonal call and assign. No change to list
context, so state ($zok) = slosh() and (state $zok) = ... etc will
still repeatedly evaluate and assign. [Can't fix that before 5.10]
Use as an RVALUE is as Larry's design - my $boff = state $zok = ...;
will evaluate, assign and return first time, and subsequently act as if
it were written my $boff = $zok;
FIXME - state $zok = ...; won't deparse - I believe op->op_last isn't
being correctly set on the sassign, but I don't know how to fix this.
This change may be backed out before 5.10.
p4raw-id: //depot/perl@31798
---
diff --git a/op.c b/op.c
index 015f26f..fefe452 100644
--- a/op.c
+++ b/op.c
@@ -6986,6 +6986,29 @@ Perl_ck_sassign(pTHX_ OP *o)
return kid;
}
}
+ if (kid->op_sibling) {
+ OP *kkid = kid->op_sibling;
+ if (kkid->op_type == OP_PADSV
+ && (kkid->op_private & OPpLVAL_INTRO)
+ && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
+ const PADOFFSET target = kkid->op_targ;
+ OP *const other = newOP(OP_PADSV,
+ kkid->op_flags
+ | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
+ OP *const first = newOP(OP_NULL, 0);
+ OP *const nullop = newCONDOP(0, first, o, other);
+ OP *const condop = first->op_next;
+ /* hijacking PADSTALE for uninitialized state variables */
+ SvPADSTALE_on(PAD_SVl(target));
+
+ condop->op_type = OP_ONCE;
+ condop->op_ppaddr = PL_ppaddr[OP_ONCE];
+ condop->op_targ = target;
+ other->op_targ = target;
+
+ return nullop;
+ }
+ }
return o;
}
@@ -7984,6 +8007,7 @@ Perl_peep(pTHX_ register OP *o)
case OP_DORASSIGN:
case OP_COND_EXPR:
case OP_RANGE:
+ case OP_ONCE:
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
diff --git a/opcode.h b/opcode.h
index 6ca4d5e..76df85c 100644
--- a/opcode.h
+++ b/opcode.h
@@ -393,6 +393,7 @@ EXTCONST char* const PL_op_name[] = {
"getlogin",
"syscall",
"lock",
+ "once",
"custom",
};
#endif
@@ -761,6 +762,7 @@ EXTCONST char* const PL_op_desc[] = {
"getlogin",
"syscall",
"lock",
+ "once",
"unknown custom operator",
};
#endif
@@ -1143,6 +1145,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
MEMBER_TO_FPTR(Perl_pp_getlogin),
MEMBER_TO_FPTR(Perl_pp_syscall),
MEMBER_TO_FPTR(Perl_pp_lock),
+ MEMBER_TO_FPTR(Perl_pp_once),
MEMBER_TO_FPTR(Perl_unimplemented_op), /* Perl_pp_custom */
}
#endif
@@ -1522,6 +1525,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
MEMBER_TO_FPTR(Perl_ck_null), /* getlogin */
MEMBER_TO_FPTR(Perl_ck_fun), /* syscall */
MEMBER_TO_FPTR(Perl_ck_rfun), /* lock */
+ MEMBER_TO_FPTR(Perl_ck_null), /* once */
MEMBER_TO_FPTR(Perl_ck_null), /* custom */
}
#endif
@@ -1895,6 +1899,7 @@ EXTCONST U32 PL_opargs[] = {
0x0000000c, /* getlogin */
0x0004281d, /* syscall */
0x0000f604, /* lock */
+ 0x00000600, /* once */
0x00000000, /* custom */
};
#endif
diff --git a/opcode.pl b/opcode.pl
index 7549844..854996d 100755
--- a/opcode.pl
+++ b/opcode.pl
@@ -1047,4 +1047,8 @@ syscall syscall ck_fun imst@ S L
# For multi-threading
lock lock ck_rfun s% R
+# For state support
+
+once once ck_null |
+
custom unknown custom operator ck_null 0
diff --git a/opnames.h b/opnames.h
index e09cb08..d2633e6 100644
--- a/opnames.h
+++ b/opnames.h
@@ -375,11 +375,12 @@ typedef enum opcode {
OP_GETLOGIN, /* 357 */
OP_SYSCALL, /* 358 */
OP_LOCK, /* 359 */
- OP_CUSTOM, /* 360 */
+ OP_ONCE, /* 360 */
+ OP_CUSTOM, /* 361 */
OP_max
} opcode;
-#define MAXO 361
+#define MAXO 362
#define OP_phoney_INPUT_ONLY -1
#define OP_phoney_OUTPUT_ONLY -2
diff --git a/pp.c b/pp.c
index dbfc95c..bc84f60 100644
--- a/pp.c
+++ b/pp.c
@@ -4932,6 +4932,19 @@ PP(pp_split)
RETURN;
}
+PP(pp_once)
+{
+ dSP;
+ SV *const sv = PAD_SVl(PL_op->op_targ);
+
+ if (SvPADSTALE(sv)) {
+ /* First time. */
+ SvPADSTALE_off(sv);
+ RETURNOP(cLOGOP->op_other);
+ }
+ RETURNOP(cLOGOP->op_next);
+}
+
PP(pp_lock)
{
dVAR;
diff --git a/pp.sym b/pp.sym
index 8e1495f..f5136ea 100644
--- a/pp.sym
+++ b/pp.sym
@@ -404,5 +404,6 @@ Perl_pp_egrent
Perl_pp_getlogin
Perl_pp_syscall
Perl_pp_lock
+Perl_pp_once
# ex: set ro:
diff --git a/pp_proto.h b/pp_proto.h
index 431992c..3a96e32 100644
--- a/pp_proto.h
+++ b/pp_proto.h
@@ -405,5 +405,6 @@ PERL_PPDEF(Perl_pp_egrent)
PERL_PPDEF(Perl_pp_getlogin)
PERL_PPDEF(Perl_pp_syscall)
PERL_PPDEF(Perl_pp_lock)
+PERL_PPDEF(Perl_pp_once)
/* ex: set ro: */
diff --git a/t/op/state.t b/t/op/state.t
index fb2880d..f7db804 100644
--- a/t/op/state.t
+++ b/t/op/state.t
@@ -10,7 +10,7 @@ BEGIN {
use strict;
use feature "state";
-plan tests => 37;
+plan tests => 38;
ok( ! defined state $uninit, q(state vars are undef by default) );
@@ -18,7 +18,7 @@ ok( ! defined state $uninit, q(state vars are undef by default) );
sub stateful {
state $x;
- state $y //= 1;
+ state $y = 1;
my $z = 2;
state ($t) //= 3;
return ($x++, $y++, $z++, $t++);
@@ -45,9 +45,9 @@ is( $t, 5, 'incremented state var, list syntax' );
# in a nested block
sub nesting {
- state $foo //= 10;
+ state $foo = 10;
my $t;
- { state $bar //= 12; $t = ++$bar }
+ { state $bar = 12; $t = ++$bar }
++$foo;
return ($foo, $t);
}
@@ -83,7 +83,7 @@ is( $f2->(), 2, 'generator 2 once more' );
sub TIESCALAR {bless {}};
sub FETCH { ++$fetchcount; 18 };
tie my $y, "countfetches";
- sub foo { state $x //= $y; $x++ }
+ sub foo { state $x = $y; $x++ }
::is( foo(), 18, "initialisation with tied variable" );
::is( foo(), 19, "increments correctly" );
::is( foo(), 20, "increments correctly, twice" );
@@ -94,7 +94,7 @@ is( $f2->(), 2, 'generator 2 once more' );
sub gen_cashier {
my $amount = shift;
- state $cash_in_store;
+ state $cash_in_store = 0;
return {
add => sub { $cash_in_store += $amount },
del => sub { $cash_in_store -= $amount },
@@ -113,7 +113,7 @@ sub stateless {
++$reinitme;
}
is( stateless(), 43, 'stateless function, first time' );
-is( stateless(), 43, 'stateless function, second time' );
+is( stateless(), 44, 'stateless function, second time' );
# array state vars
@@ -157,3 +157,4 @@ noseworth(2);
sub pugnax { my $x = state $y = 42; $y++; $x; }
is( pugnax(), 42, 'scalar state assignment return value' );
+is( pugnax(), 43, 'scalar state assignment return value' );