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 (file)
--- 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 (file)
--- 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 (executable)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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' );