Create all and any operators

As these only permit `any BLOCK LIST` and not the deferred-expression
form like `grep EXPR, LIST`, we create a whole new token type, BLKLSTOP,
to represent these. The parser then only accepts the block form and not
the expression form when parsing these.

Author: leonerd

MANIFEST

@@ -6256,6 +6256,7 @@ t/op/aassign.t				test list assign
 t/op/alarm.t				See if alarm works
 t/op/anonconst.t			See if :const works
 t/op/anonsub.t				See if anonymous subroutines work
+t/op/any_all.t				See if feature 'any_all' works
 t/op/append.t				See if . works
 t/op/args.t				See if operations on @_ work
 t/op/arith2.t				See if arithmetic works

embed.fnc

@@ -5897,7 +5897,8 @@ S	|int	|intuit_method	|NN char *s				\
 				|NULLOK NOCHECK CV *cv
 S	|int	|intuit_more	|NN char *s				\
 				|NN char *e
-S	|I32	|lop		|I32 f					\
+S	|I32	|lop		|enum yytokentype t			\
+				|I32 f					\
 				|U8 x					\
 				|NN char *s
 Sr	|void	|missingterm	|NULLOK char *s 			\

embed.h

@@ -1700,7 +1700,7 @@
 #     define incline(a,b)                       S_incline(aTHX_ a,b)
 #     define intuit_method(a,b,c)               S_intuit_method(aTHX_ a,b,c)
 #     define intuit_more(a,b)                   S_intuit_more(aTHX_ a,b)
-#     define lop(a,b,c)                         S_lop(aTHX_ a,b,c)
+#     define lop(a,b,c,d)                       S_lop(aTHX_ a,b,c,d)
 #     define missingterm(a,b)                   S_missingterm(aTHX_ a,b)
 #     define parse_ident(a,b,c,d,e,f)           S_parse_ident(aTHX_ a,b,c,d,e,f)
 #     define pending_ident()                    S_pending_ident(aTHX)

ext/Opcode/Opcode.pm

@@ -1,4 +1,4 @@
-package Opcode 1.66;
+package Opcode 1.67;
 
 use strict;
 
@@ -377,6 +377,7 @@ used to implement a resource attack (e.g., consume all available CPU time).
 
     grepstart grepwhile
     mapstart mapwhile
+    anystart allstart anywhile
     enteriter iter
     enterloop leaveloop unstack
     last next redo

gv.c

@@ -610,7 +610,8 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
     case KEY___DATA__: case KEY___END__ :
     case KEY_ADJUST  : case KEY_AUTOLOAD: case KEY_BEGIN : case KEY_CHECK :
     case KEY_DESTROY : case KEY_END     : case KEY_INIT  : case KEY_UNITCHECK:
-    case KEY_and     : case KEY_catch   : case KEY_class :
+    case KEY_all     : case KEY_and     : case KEY_any   :
+    case KEY_catch   : case KEY_class   :
     case KEY_continue: case KEY_cmp     : case KEY_defer :
     case KEY_do      : case KEY_dump   : case KEY_else  : case KEY_elsif  :
     case KEY_eq     : case KEY_eval  : case KEY_field  :

lib/B/Deparse-core.t

@@ -91,6 +91,7 @@ sub testit {
         else {
             package test;
             use subs ();
+            no warnings 'experimental::any_all';
             import subs $keyword;
             $code = "no warnings 'syntax'; no strict 'vars'; sub { ${vars}() = $expr }";
             $code = "use feature 'isa';\n$code" if $keyword eq "isa";
@@ -232,6 +233,9 @@ while (<DATA>) {
 
 # Special cases
 
+testit any      => 'CORE::any { $a } $b, $c',    'CORE::any({$a;} $b, $c);';
+testit all      => 'CORE::all { $a } $b, $c',    'CORE::all({$a;} $b, $c);';
+
 testit dbmopen  => 'CORE::dbmopen(%foo, $bar, $baz);';
 testit dbmclose => 'CORE::dbmclose %foo;';
 

lib/B/Deparse.pm

@@ -7,7 +7,7 @@
 # This is based on the module of the same name by Malcolm Beattie,
 # but essentially none of his code remains.
 
-package B::Deparse 1.80;
+package B::Deparse 1.81;
 use strict;
 use Carp;
 use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
@@ -2334,6 +2334,8 @@ my %feature_keywords = (
    finally  => 'try',
    defer    => 'defer',
    signatures => 'signatures',
+   any      => 'any_all',
+   all      => 'any_all',
 );
 
 # keywords that are strong and also have a prototype
@@ -3637,9 +3639,10 @@ sub pp_sort { indirop(@_, "sort") }
 
 sub mapop {
     my $self = shift;
-    my($op, $cx, $name) = @_;
+    my($op, $cx) = @_;
     my($expr, @exprs);
-    my $kid = $op->first; # this is the (map|grep)start
+    my $kid = $op->first; # this is the (map|grep\any|all)start
+    my ( $name ) = $kid->name =~ m/(.*)start/; # anystart and allstart share anywhile
     $kid = $kid->first->sibling; # skip a pushmark
     my $code = $kid->first; # skip a null
     if (is_scope $code) {
@@ -3657,8 +3660,9 @@ sub mapop {
 				    $code . join(", ", @exprs), $cx, 5);
 }
 
-sub pp_mapwhile { mapop(@_, "map") }
-sub pp_grepwhile { mapop(@_, "grep") }
+sub pp_mapwhile { mapop(@_) }
+sub pp_grepwhile { mapop(@_) }
+sub pp_anywhile { mapop(@_) }
 sub pp_mapstart { baseop(@_, "map") }
 sub pp_grepstart { baseop(@_, "grep") }
 

lib/B/Op_private.pm

@@ -12060,8 +12060,16 @@ Constructs, checks, and returns a glob reference op.
 OP *
 Perl_newGVREF(pTHX_ I32 type, OP *o)
 {
-    if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
-        return newUNOP(OP_NULL, 0, o);
+    switch(type) {
+        /* The thing that looks like a GVREF at the start of these operators
+         * isn't really */
+        case OP_MAPSTART:
+        case OP_GREPSTART:
+        case OP_SORT:
+        case OP_ANYSTART:
+        case OP_ALLSTART:
+            return newUNOP(OP_NULL, 0, o);
+    }
 
     if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED &&
         ((PL_opargs[type] >> OASHIFT) & 7) == OA_FILEREF &&
@@ -13202,7 +13210,10 @@ Perl_ck_grep(pTHX_ OP *o)
 {
     LOGOP *gwop;
     OP *kid;
-    const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
+    const OPCODE type =
+        o->op_type == OP_GREPSTART ? OP_GREPWHILE :
+        o->op_type == OP_MAPSTART  ? OP_MAPWHILE  :
+                                     OP_ANYWHILE;  /* any and all both share this */
 
     PERL_ARGS_ASSERT_CK_GREP;