This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
initialisation of simple aggregate state variables
authorZefram <zefram@fysh.org>
Sat, 4 Nov 2017 21:43:59 +0000 (21:43 +0000)
committerZefram <zefram@fysh.org>
Sat, 4 Nov 2017 21:46:47 +0000 (21:46 +0000)
We now recognise the basic cases of aggregate state variables, to
permit initialisations of the form "state @a =" or "state @a :shared =".
Initialisation of state variable lists remains forbidden, because the
op flags don't let us distinguish "state(...)" from "(state(...))" in
most cases.

op.c
pod/perldelta.pod
pod/perldiag.pod
pod/perlfunc.pod
pod/perlsub.pod
t/lib/croak/op
t/op/state.t

diff --git a/op.c b/op.c
index 333e5b1..9d0facd 100644 (file)
--- a/op.c
+++ b/op.c
@@ -7599,6 +7599,33 @@ S_assignment_type(pTHX_ const OP *o)
     return ret;
 }
 
+static OP *
+S_newONCEOP(pTHX_ OP *initop, OP *padop)
+{
+    const PADOFFSET target = padop->op_targ;
+    OP *const other = newOP(OP_PADSV,
+                           padop->op_flags
+                           | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
+    OP *const first = newOP(OP_NULL, 0);
+    OP *const nullop = newCONDOP(0, first, initop, other);
+    /* XXX targlex disabled for now; see ticket #124160
+       newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
+     */
+    OP *const condop = first->op_next;
+
+    OpTYPE_set(condop, OP_ONCE);
+    other->op_targ = target;
+    nullop->op_flags |= OPf_WANT_SCALAR;
+
+    /* Store the initializedness of state vars in a separate
+       pad entry.  */
+    condop->op_targ =
+      pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
+    /* hijacking PADSTALE for uninitialized state variables */
+    SvPADSTALE_on(PAD_SVl(condop->op_targ));
+
+    return nullop;
+}
 
 /*
 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
@@ -7643,8 +7670,9 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
     }
 
     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
+       OP *state_var_op = NULL;
        static const char no_list_state[] = "Initialization of state variables"
-           " in list context currently forbidden";
+           " in list currently forbidden";
        OP *curop;
 
        if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
@@ -7658,16 +7686,29 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 
        if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
        {
-           OP* lop = ((LISTOP*)left)->op_first;
-           while (lop) {
-               if ((lop->op_type == OP_PADSV ||
-                    lop->op_type == OP_PADAV ||
-                    lop->op_type == OP_PADHV ||
-                    lop->op_type == OP_PADANY)
-                 && (lop->op_private & OPpPAD_STATE)
-                )
-                    yyerror(no_list_state);
-               lop = OpSIBLING(lop);
+           OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
+           if (!(left->op_flags & OPf_PARENS) &&
+                   lop->op_type == OP_PUSHMARK &&
+                   (vop = OpSIBLING(lop)) &&
+                   (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
+                   !(vop->op_flags & OPf_PARENS) &&
+                   (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
+                       (OPpLVAL_INTRO|OPpPAD_STATE) &&
+                   (eop = OpSIBLING(vop)) &&
+                   eop->op_type == OP_ENTERSUB &&
+                   !OpHAS_SIBLING(eop)) {
+               state_var_op = vop;
+           } else {
+               while (lop) {
+                   if ((lop->op_type == OP_PADSV ||
+                        lop->op_type == OP_PADAV ||
+                        lop->op_type == OP_PADHV ||
+                        lop->op_type == OP_PADANY)
+                     && (lop->op_private & OPpPAD_STATE)
+                   )
+                       yyerror(no_list_state);
+                   lop = OpSIBLING(lop);
+               }
            }
        }
        else if (  (left->op_private & OPpLVAL_INTRO)
@@ -7687,7 +7728,10 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
                   state (%a) = ...
                   (state %a) = ...
                */
-               yyerror(no_list_state);
+                if (left->op_flags & OPf_PARENS)
+                   yyerror(no_list_state);
+               else
+                   state_var_op = left;
        }
 
         /* optimise @a = split(...) into:
@@ -7779,6 +7823,9 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
                 }
             }
        }
+
+       if (state_var_op)
+           o = S_newONCEOP(aTHX_ o, state_var_op);
        return o;
     }
     if (assign_type == ASSIGN_REF)
@@ -11724,30 +11771,7 @@ Perl_ck_sassign(pTHX_ OP *o)
            )
                && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
                    == (OPpLVAL_INTRO|OPpPAD_STATE)) {
-           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);
-           /* XXX targlex disabled for now; see ticket #124160
-               newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
-            */
-           OP *const condop = first->op_next;
-
-            OpTYPE_set(condop, OP_ONCE);
-           other->op_targ = target;
-           nullop->op_flags |= OPf_WANT_SCALAR;
-
-           /* Store the initializedness of state vars in a separate
-              pad entry.  */
-           condop->op_targ =
-             pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
-           /* hijacking PADSTALE for uninitialized state variables */
-           SvPADSTALE_on(PAD_SVl(condop->op_targ));
-
-           return nullop;
+           return S_newONCEOP(aTHX_ o, kkid);
        }
     }
     return S_maybe_targlex(aTHX_ o);
index 4b6664d..e1e608c 100644 (file)
@@ -27,6 +27,12 @@ here, but most should go in the L</Performance Enhancements> section.
 
 [ List each enhancement as a =head2 entry ]
 
+=head2 Initialisation of aggregate state variables
+
+A persistent lexical array or hash variable can now be initialized,
+by an expression such as C<state @a = qw(x y z)>.  Initialization of a
+list of persistent lexical variables is still not possible.
+
 =head1 Security
 
 XXX Any security-related notices go here.  In particular, any security
@@ -257,6 +263,13 @@ XXX Changes (i.e. rewording) of diagnostic messages go here
 
 =item *
 
+The diagnostic C<Initialization of state variables in list context
+currently forbidden> has changed to C<Initialization of state variables
+in list currently forbidden>, because list-context initialization of
+single aggregate state variables is now permitted.
+
+=item *
+
 XXX Describe change here
 
 =back
index dee59d9..2cf2040 100644 (file)
@@ -2827,12 +2827,12 @@ for instance C</(?{ s!!! })/>, which resulted in re-executing
 the same pattern, which is an infinite loop which is broken by
 throwing an exception.
 
-=item Initialization of state variables in list context currently forbidden
+=item Initialization of state variables in list currently forbidden
 
-(F) C<state> only permits initializing a single scalar variable, in scalar
-context.  So C<state $a = 42> is allowed, but not C<state ($a) = 42>.  To apply
-state semantics to a hash or array, store a hash or array reference in a
-scalar variable.
+(F) C<state> only permits initializing a single variable, specified
+without parentheses.  So C<state $a = 42> and C<state @a = qw(a b c)> are
+allowed, but not C<state ($a) = 42> or C<(state $a) = 42>.  To initialize
+more than one C<state> variable, initialize them one at a time.
 
 =item %%s[%s] in scalar context better written as $%s[%s]
 
index e753d5f..b571faf 100644 (file)
@@ -8341,7 +8341,7 @@ If more than one variable is listed, the list must be placed in
 parentheses.  With a parenthesised list, L<C<undef>|/undef EXPR> can be
 used as a
 dummy placeholder.  However, since initialization of state variables in
-list context is currently not possible this would serve no purpose.
+such lists is currently not possible this would serve no purpose.
 
 L<C<state>|/state VARLIST> is available only if the
 L<C<"state"> feature|feature/The 'state' feature> is enabled or if it is
index 689d4a3..8490630 100644 (file)
@@ -736,10 +736,11 @@ And this example uses anonymous subroutines to create separate counters:
 Also, since C<$x> is lexical, it can't be reached or modified by any Perl
 code outside.
 
-When combined with variable declaration, simple scalar assignment to C<state>
+When combined with variable declaration, simple assignment to C<state>
 variables (as in C<state $x = 42>) is executed only the first time.  When such
 statements are evaluated subsequent times, the assignment is ignored.  The
-behavior of this sort of assignment to non-scalar variables is undefined.
+behavior of assignment to C<state> declarations where the left hand side
+of the assignment involves any parentheses is currently undefined.
 
 =head3 Persistent variables with closures
 
index 7095ad8..002eb26 100644 (file)
@@ -152,13 +152,13 @@ Execution of - aborted due to compilation errors.
 # NAME ($_, state $x) = ...
 ($_, CORE::state $x) = ();
 EXPECT
-Initialization of state variables in list context currently forbidden at - line 1, near ");"
+Initialization of state variables in list currently forbidden at - line 1, near ");"
 Execution of - aborted due to compilation errors.
 ########
 # NAME my $y; ($y, state $x) = ...
 my $y; ($y, CORE::state $x) = ();
 EXPECT
-Initialization of state variables in list context currently forbidden at - line 1, near ");"
+Initialization of state variables in list currently forbidden at - line 1, near ");"
 Execution of - aborted due to compilation errors.
 ########
 # NAME delete BAD
index 39eeecd..01bc007 100644 (file)
@@ -9,7 +9,7 @@ BEGIN {
 
 use strict;
 
-plan tests => 126;
+plan tests => 164;
 
 # Before loading feature.pm, test it with CORE::
 ok eval 'CORE::state $x = 1;', 'CORE::state outside of feature.pm scope';
@@ -135,6 +135,16 @@ is( $xsize, 0, 'uninitialized state array' );
 $xsize = stateful_array();
 is( $xsize, 1, 'uninitialized state array after one iteration' );
 
+sub stateful_init_array {
+    state @x = qw(a b c);
+    push @x, "x";
+    return join(",", @x);
+}
+
+is stateful_init_array(), "a,b,c,x";
+is stateful_init_array(), "a,b,c,x,x";
+is stateful_init_array(), "a,b,c,x,x,x";
+
 # hash state vars
 
 sub stateful_hash {
@@ -148,6 +158,39 @@ is( $xhval, 0, 'uninitialized state hash' );
 $xhval = stateful_hash();
 is( $xhval, 1, 'uninitialized state hash after one iteration' );
 
+sub stateful_init_hash {
+    state %x = qw(a b c d);
+    $x{foo}++;
+    return join(",", map { ($_, $x{$_}) } sort keys %x);
+}
+
+is stateful_init_hash(), "a,b,c,d,foo,1";
+is stateful_init_hash(), "a,b,c,d,foo,2";
+is stateful_init_hash(), "a,b,c,d,foo,3";
+
+# declarations with attributes
+
+sub stateful_attr {
+    state $a :shared;
+    state $b :shared = 3;
+    state @c :shared;
+    state @d :shared = qw(a b c);
+    state %e :shared;
+    state %f :shared = qw(a b c d);
+    $a++;
+    $b++;
+    push @c, "x";
+    push @d, "x";
+    $e{e}++;
+    $f{e}++;
+    return join(",", $a, $b, join(":", @c), join(":", @d), join(":", %e),
+           join(":", map { ($_, $f{$_}) } sort keys %f));
+}
+
+is stateful_attr(), "1,4,x,a:b:c:x,e:1,a:b:c:d:e:1";
+is stateful_attr(), "2,5,x:x,a:b:c:x:x,e:2,a:b:c:d:e:2";
+is stateful_attr(), "3,6,x:x:x,a:b:c:x:x:x,e:3,a:b:c:d:e:3";
+
 # Recursion
 
 sub noseworth {
@@ -344,7 +387,7 @@ foreach my $forbidden (<DATA>) {
     chomp $forbidden;
     no strict 'vars';
     eval $forbidden;
-    like $@, qr/Initialization of state variables in list context currently forbidden/, "Currently forbidden: $forbidden";
+    like $@, qr/Initialization of state variables in list currently forbidden/, "Currently forbidden: $forbidden";
 }
 
 # [perl #49522] state variable not available
@@ -447,16 +490,45 @@ for (1,2) {
 }
 
 __DATA__
-state ($a) = 1;
 (state $a) = 1;
-state @a = 1;
-state (@a) = 1;
 (state @a) = 1;
-state %a = ();
-state (%a) = ();
+(state @a :shared) = 1;
 (state %a) = ();
+(state %a :shared) = ();
+state ($a) = 1;
+(state ($a)) = 1;
+state (@a) = 1;
+(state (@a)) = 1;
+state (@a) :shared = 1;
+(state (@a) :shared) = 1;
+state (%a) = ();
+(state (%a)) = ();
+state (%a) :shared = ();
+(state (%a) :shared) = ();
+state (undef, $a) = ();
+(state (undef, $a)) = ();
+state (undef, @a) = ();
+(state (undef, @a)) = ();
+state ($a, undef) = ();
+(state ($a, undef)) = ();
 state ($a, $b) = ();
+(state ($a, $b)) = ();
+state ($a, $b) :shared = ();
+(state ($a, $b) :shared) = ();
 state ($a, @b) = ();
+(state ($a, @b)) = ();
+state ($a, @b) :shared = ();
+(state ($a, @b) :shared) = ();
+state (@a, undef) = ();
+(state (@a, undef)) = ();
+state (@a, $b) = ();
+(state (@a, $b)) = ();
+state (@a, $b) :shared = ();
+(state (@a, $b) :shared) = ();
+state (@a, @b) = ();
+(state (@a, @b)) = ();
+state (@a, @b) :shared = ();
+(state (@a, @b) :shared) = ();
 (state $a, state $b) = ();
 (state $a, $b) = ();
 (state $a, my $b) = ();