From c5917253cfa0ec36b4c868a1582baaaab99eb0d0 Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Thu, 6 Sep 2007 09:18:41 +0000 Subject: 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 --- op.c | 24 ++++++++++++++++++++++++ opcode.h | 5 +++++ opcode.pl | 4 ++++ opnames.h | 5 +++-- pp.c | 13 +++++++++++++ pp.sym | 1 + pp_proto.h | 1 + t/op/state.t | 15 ++++++++------- 8 files changed, 59 insertions(+), 9 deletions(-) diff --git a/op.c b/op.c index 015f26f908..fefe45227b 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 6ca4d5e25f..76df85cbb9 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 7549844bb8..854996dfb4 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 e09cb084d2..d2633e6bc5 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 dbfc95c567..bc84f6086d 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 8e1495f296..f5136ea252 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 431992c0b0..3a96e32837 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 fb2880d852..f7db80401c 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' ); -- cgit v1.2.1