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;
 }
 
     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
 
 /*
 =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) {
     }
 
     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
+       OP *state_var_op = NULL;
        static const char no_list_state[] = "Initialization of state variables"
        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)
        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))
        {
 
        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)
            }
        }
        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) = ...
                */
                   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:
        }
 
         /* 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)
        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)) {
            )
                && (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);
        }
     }
     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 ]
 
 
 [ 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
 =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 *
 
 
 =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
 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.
 
 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]
 
 
 =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
 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
 
 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.
 
 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
 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
 
 
 =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
 # 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
 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
 Execution of - aborted due to compilation errors.
 ########
 # NAME delete BAD
index 39eeecd..01bc007 100644 (file)
@@ -9,7 +9,7 @@ BEGIN {
 
 use strict;
 
 
 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';
 
 # 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' );
 
 $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 {
 # 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' );
 
 $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 {
 # Recursion
 
 sub noseworth {
@@ -344,7 +387,7 @@ foreach my $forbidden (<DATA>) {
     chomp $forbidden;
     no strict 'vars';
     eval $forbidden;
     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
 }
 
 # [perl #49522] state variable not available
@@ -447,16 +490,45 @@ for (1,2) {
 }
 
 __DATA__
 }
 
 __DATA__
-state ($a) = 1;
 (state $a) = 1;
 (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) = ();
+(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)) = ();
+state ($a, $b) :shared = ();
+(state ($a, $b) :shared) = ();
 state ($a, @b) = ();
 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) = ();
 (state $a, state $b) = ();
 (state $a, $b) = ();
 (state $a, my $b) = ();