add UNOP_AUX OP class

This is the same as a UNOP, but with the addition of an op_aux field,
which points to an array of UNOP_AUX_item unions.

It is intended as a general escape mechanism for adding per-op-type extra
fields (or arrays of items) to UNOPs.

Its class character (for regen/opcodes etc) is '+'.

Currently there are no ops of this type; but shortly, OP_MULTIDEREF will
be added, which is the original motivation for this new op type.

12 files changed, 161 insertions, 13 deletions

diff --git a/embed.fnc b/embed.fnc
index 0af427ebd8..26d893d13d 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1032,6 +1032,8 @@ Apd	|SV*	|newSVrv	|NN SV *const rv|NULLOK const char *const classname
 Apda	|SV*	|newSVsv	|NULLOK SV *const old
 Apda	|SV*	|newSV_type	|const svtype type
 Apda	|OP*	|newUNOP	|I32 type|I32 flags|NULLOK OP* first
+Apda	|OP*	|newUNOP_AUX	|I32 type|I32 flags|NULLOK OP* first \
+				|NULLOK UNOP_AUX_item *aux
 Apda	|OP*	|newWHENOP	|NULLOK OP* cond|NN OP* block
 Apda	|OP*	|newWHILEOP	|I32 flags|I32 debuggable|NULLOK LOOP* loop \
 				|NULLOK OP* expr|NULLOK OP* block|NULLOK OP* cont \
diff --git a/embed.h b/embed.h
index 91ef308796..7108b3e331 100644
--- a/embed.h
+++ b/embed.h
@@ -414,6 +414,7 @@
 #define newSVsv(a)		Perl_newSVsv(aTHX_ a)
 #define newSVuv(a)		Perl_newSVuv(aTHX_ a)
 #define newUNOP(a,b,c)		Perl_newUNOP(aTHX_ a,b,c)
+#define newUNOP_AUX(a,b,c,d)	Perl_newUNOP_AUX(aTHX_ a,b,c,d)
 #define newWHENOP(a,b)		Perl_newWHENOP(aTHX_ a,b)
 #define newWHILEOP(a,b,c,d,e,f,g)	Perl_newWHILEOP(aTHX_ a,b,c,d,e,f,g)
 #define newXS(a,b,c)		Perl_newXS(aTHX_ a,b,c)
diff --git a/ext/B/B.pm b/ext/B/B.pm
index 4dffea1249..75054f4d4a 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -60,6 +60,7 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs
 
 @B::OP::ISA = 'B::OBJECT';
 @B::UNOP::ISA = 'B::OP';
+@B::UNOP_AUX::ISA = 'B::UNOP';
 @B::BINOP::ISA = 'B::UNOP';
 @B::LOGOP::ISA = 'B::UNOP';
 @B::LISTOP::ISA = 'B::BINOP';
@@ -73,7 +74,8 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs
 
 @B::SPECIAL::ISA = 'B::OBJECT';
 
-@B::optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP METHOP);
+@B::optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP
+                METHOP UNOP_AUX);
 # bytecode.pl contained the following comment:
 # Nullsv *must* come first in the following so that the condition
 # ($$sv == 0) can continue to be used to test (sv == Nullsv).
@@ -1089,8 +1091,9 @@ information is no longer stored directly in the hash.
 
 =head2 OP-RELATED CLASSES
 
-C<B::OP>, C<B::UNOP>, C<B::BINOP>, C<B::LOGOP>, C<B::LISTOP>, C<B::PMOP>,
-C<B::SVOP>, C<B::PADOP>, C<B::PVOP>, C<B::LOOP>, C<B::COP>, C<B::METHOP>.
+C<B::OP>, C<B::UNOP>, C<B::UNOP_AUX>, C<B::BINOP>, C<B::LOGOP>,
+C<B::LISTOP>, C<B::PMOP>, C<B::SVOP>, C<B::PADOP>, C<B::PVOP>, C<B::LOOP>,
+C<B::COP>, C<B::METHOP>.
 
 These classes correspond in the obvious way to the underlying C
 structures of similar names.  The inheritance hierarchy mimics the
@@ -1101,15 +1104,17 @@ underlying C "inheritance":
                    +----------+---------+--------+-------+---------+
                    |          |         |        |       |         |
                 B::UNOP    B::SVOP  B::PADOP  B::COP  B::PVOP  B::METHOP
-                 ,'  `-.
-                /       `--.
-           B::BINOP     B::LOGOP
+                   |
+               +---+---+---------+
+               |       |         |
+           B::BINOP  B::LOGOP  B::UNOP_AUX
                |
                |
            B::LISTOP
-             ,' `.
-            /     \
-        B::LOOP B::PMOP
+               |
+           +---+---+
+           |       |
+        B::LOOP   B::PMOP
 
 Access methods correspond to the underlying C structure field names,
 with the leading "class indication" prefix (C<"op_">) removed.
@@ -1166,6 +1171,27 @@ This returns the op description from the global C PL_op_desc array
 
 =back
 
+=head2 B::UNOP_AUX METHODS (since 5.22)
+
+=over 4
+
+=item aux_list(cv)
+
+This returns a list of the elements of the op's aux data structure,
+or a null list if there is no aux. What will be returned depends on the
+object's type, but will typically be a collection of C<B::IV>, C<B::GV>,
+etc. objects. C<cv> is the C<B::CV> object representing the sub that the
+op is contained within.
+
+=item string(cv)
+
+This returns a textual representation of the object (likely to b useful
+for deparsing and debugging), or an empty string if the op type doesn't
+support this. C<cv> is the C<B::CV> object representing the sub that the
+op is contained within.
+
+=back
+
 =head2 B::BINOP METHOD
 
 =over 4
diff --git a/ext/B/B.xs b/ext/B/B.xs
index da05cc18f2..937ef2c43f 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -61,7 +61,8 @@ typedef enum {
     OPc_PVOP,	/* 9 */
     OPc_LOOP,	/* 10 */
     OPc_COP,	/* 11 */
-    OPc_METHOP	/* 12 */
+    OPc_METHOP,	/* 12 */
+    OPc_UNOP_AUX /* 13 */
 } opclass;
 
 static const char* const opclassnames[] = {
@@ -77,7 +78,8 @@ static const char* const opclassnames[] = {
     "B::PVOP",
     "B::LOOP",
     "B::COP",
-    "B::METHOP"
+    "B::METHOP",
+    "B::UNOP_AUX"
 };
 
 static const size_t opsizes[] = {
@@ -93,7 +95,8 @@ static const size_t opsizes[] = {
     sizeof(PVOP),
     sizeof(LOOP),
     sizeof(COP),
-    sizeof(METHOP)
+    sizeof(METHOP),
+    sizeof(UNOP_AUX),
 };
 
 #define MY_CXT_KEY "B::_guts" XS_VERSION
@@ -240,6 +243,8 @@ cc_opclass(pTHX_ const OP *o)
 	    return OPc_PVOP;
     case OA_METHOP:
 	return OPc_METHOP;
+    case OA_UNOP_AUX:
+	return OPc_UNOP_AUX;
     }
     warn("can't determine class of operator %s, assuming BASEOP\n",
 	 OP_NAME(o));
@@ -1317,6 +1322,50 @@ oplist(o)
 	SP = oplist(aTHX_ o, SP);
 
 
+
+MODULE = B	PACKAGE = B::UNOP_AUX
+
+# UNOP_AUX class ops are like UNOPs except that they have an extra
+# op_aux pointer that points to an array of UNOP_AUX_item unions.
+# Element -1 of the array contains the length
+
+
+# return a string representation of op_aux where possible The op's CV is
+# needed as an extra arg to allow GVs and SVs moved into the pad to be
+# accessed okay.
+
+void
+string(o, cv)
+	B::OP  o
+	B::CV  cv
+    PREINIT:
+	SV *ret;
+    PPCODE:
+        switch (o->op_type) {
+        default:
+            ret = sv_2mortal(newSVpvn("", 0));
+        }
+	ST(0) = ret;
+	XSRETURN(1);
+
+
+# Return the contents of the op_aux array as a list of IV/GV/etc objects.
+# How to interpret each array element is op-dependent. The op's CV is
+# needed as an extra arg to allow GVs and SVs which have been moved into
+# the pad to be accessed okay.
+
+void
+aux_list(o, cv)
+	B::OP  o
+	B::CV  cv
+    PPCODE:
+        switch (o->op_type) {
+        default:
+            XSRETURN(0); /* by default, an empty list */
+        } /* switch */
+
+
+
 MODULE = B	PACKAGE = B::SV
 
 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 5e068b72e2..381181e6d2 100644
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -401,7 +401,7 @@ my $lastnext;	# remembers op-chain, used to insert gotos
 my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
 	       'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
 	       'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#",
-	       'METHOP' => '.');
+	       'METHOP' => '.', UNOP_AUX => '+');
 
 no warnings 'qw'; # "Possible attempt to put comments..."; use #7
 my @linenoise =
@@ -915,6 +915,10 @@ sub concise_op {
             }
         }
     }
+    elsif ($h{class} eq "UNOP_AUX") {
+        $h{arg} = "(" . $op->string . ")";
+    }
+
     $h{seq} = $h{hyphseq} = seq($op);
     $h{seq} = "" if $h{seq} eq "-";
     $h{opt} = $op->opt;
@@ -1383,6 +1387,7 @@ B:: namespace that represents the ops in your Perl code.
 
     0      OP (aka BASEOP)  An OP with no children
     1      UNOP             An OP with one child
+    +      UNOP_AUX         A UNOP with auxillary fields
     2      BINOP            An OP with two children
     |      LOGOP            A control branch OP
     @      LISTOP           An OP that could have lots of children
diff --git a/op.c b/op.c
index a95c6f40e9..f34e9326f7 100644
--- a/op.c
+++ b/op.c
@@ -2424,6 +2424,7 @@ S_finalize_op(pTHX_ OP* o)
         assert(  has_last /* has op_first and op_last, or ...
               ... has (or may have) op_first: */
               || family == OA_UNOP
+              || family == OA_UNOP_AUX
               || family == OA_LOGOP
               || family == OA_BASEOP_OR_UNOP
               || family == OA_FILESTATOP
@@ -4704,6 +4705,43 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
 }
 
 /*
+=for apidoc
+
+Similar to C<newUNOP>, but creates an UNOP_AUX struct instead, with op_aux
+initialised to aux
+
+=cut
+*/
+
+OP *
+Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
+{
+    dVAR;
+    UNOP_AUX *unop;
+
+    assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX);
+
+    NewOp(1101, unop, 1, UNOP_AUX);
+    unop->op_type = (OPCODE)type;
+    unop->op_ppaddr = PL_ppaddr[type];
+    unop->op_first = first;
+    unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
+    unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
+    unop->op_aux = aux;
+
+#ifdef PERL_OP_PARENT
+    if (first && !OP_HAS_SIBLING(first)) /* true unless weird syntax error */
+        first->op_sibling = (OP*)unop;
+#endif
+
+    unop = (UNOP_AUX*) CHECKOP(type, unop);
+    if (unop->op_next)
+	return (OP*)unop;
+
+    return fold_constants(op_integerize(op_std_init((OP *) unop)));
+}
+
+/*
 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
 
 Constructs, checks, and returns an op of method type with a method name
diff --git a/op.h b/op.h
index befdc79ee4..61a382fb76 100644
--- a/op.h
+++ b/op.h
@@ -169,6 +169,14 @@ Deprecated.  Use C<GIMME_V> instead.
 #define OPpENTERSUB_LVAL_MASK (OPpLVAL_INTRO|OPpENTERSUB_INARGS)
 
 
+/* things that can be elements of op_aux */
+typedef union  {
+    PADOFFSET pad_offset;
+    SV        *sv;
+    IV        iv;
+    UV        uv;
+} UNOP_AUX_item;
+
 
 struct op {
     BASEOP
@@ -179,6 +187,12 @@ struct unop {
     OP *	op_first;
 };
 
+struct unop_aux {
+    BASEOP
+    OP  	  *op_first;
+    UNOP_AUX_item *op_aux;
+};
+
 struct binop {
     BASEOP
     OP *	op_first;
@@ -394,6 +408,7 @@ struct loop {
 };
 
 #define cUNOPx(o)	((UNOP*)o)
+#define cUNOP_AUXx(o)	((UNOP_AUX*)o)
 #define cBINOPx(o)	((BINOP*)o)
 #define cLISTOPx(o)	((LISTOP*)o)
 #define cLOGOPx(o)	((LOGOP*)o)
@@ -406,6 +421,7 @@ struct loop {
 #define cMETHOPx(o)	((METHOP*)o)
 
 #define cUNOP		cUNOPx(PL_op)
+#define cUNOP_AUX	cUNOP_AUXx(PL_op)
 #define cBINOP		cBINOPx(PL_op)
 #define cLISTOP		cLISTOPx(PL_op)
 #define cLOGOP		cLOGOPx(PL_op)
@@ -417,6 +433,7 @@ struct loop {
 #define cLOOP		cLOOPx(PL_op)
 
 #define cUNOPo		cUNOPx(o)
+#define cUNOP_AUXo	cUNOP_AUXx(o)
 #define cBINOPo		cBINOPx(o)
 #define cLISTOPo	cLISTOPx(o)
 #define cLOGOPo		cLOGOPx(o)
@@ -428,6 +445,7 @@ struct loop {
 #define cLOOPo		cLOOPx(o)
 
 #define kUNOP		cUNOPx(kid)
+#define kUNOP_AUX	cUNOP_AUXx(kid)
 #define kBINOP		cBINOPx(kid)
 #define kLISTOP		cLISTOPx(kid)
 #define kLOGOP		cLOGOPx(kid)
@@ -505,6 +523,7 @@ struct loop {
 #define OA_FILESTATOP (12 << OCSHIFT)
 #define OA_LOOPEXOP (13 << OCSHIFT)
 #define OA_METHOP (14 << OCSHIFT)
+#define OA_UNOP_AUX (15 << OCSHIFT)
 
 /* Each remaining nybble of PL_opargs (i.e. bits 12..15, 16..19 etc)
  * encode the type for each arg */
diff --git a/perl.h b/perl.h
index 8466bc76bd..2a77522c5e 100644
--- a/perl.h
+++ b/perl.h
@@ -2594,6 +2594,7 @@ typedef MEM_SIZE STRLEN;
 typedef struct op OP;
 typedef struct cop COP;
 typedef struct unop UNOP;
+typedef struct unop_aux UNOP_AUX;
 typedef struct binop BINOP;
 typedef struct listop LISTOP;
 typedef struct logop LOGOP;
diff --git a/proto.h b/proto.h
index 8ac92dd3c0..eb2ba5a9ad 100644
--- a/proto.h
+++ b/proto.h
@@ -3134,6 +3134,10 @@ PERL_CALLCONV OP*	Perl_newUNOP(pTHX_ I32 type, I32 flags, OP* first)
 			__attribute__malloc__
 			__attribute__warn_unused_result__;
 
+PERL_CALLCONV OP*	Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP* first, UNOP_AUX_item *aux)
+			__attribute__malloc__
+			__attribute__warn_unused_result__;
+
 PERL_CALLCONV OP*	Perl_newWHENOP(pTHX_ OP* cond, OP* block)
 			__attribute__malloc__
 			__attribute__warn_unused_result__
diff --git a/regen/op_private b/regen/op_private
index d8cf6e6f34..731c4fb490 100644
--- a/regen/op_private
+++ b/regen/op_private
@@ -204,6 +204,7 @@ use strict;
                         qw(reverse), # ck_fun(), but most bits stolen
                         grep !$maxarg{$_} && !$args0{$_},
                             ops_with_flag('1'), # UNOP
+                            ops_with_flag('+'), # UNOP_AUX
                             ops_with_flag('%'), # BASEOP/UNOP
                             ops_with_flag('|'), # LOGOP
                             ops_with_flag('-'), # FILESTATOP
diff --git a/regen/opcode.pl b/regen/opcode.pl
index fa9127c21f..327e45eda1 100755
--- a/regen/opcode.pl
+++ b/regen/opcode.pl
@@ -1114,6 +1114,7 @@ my %opclass = (
     '-',  12,		# filestatop
     '}',  13,		# loopexop
     '.',  14,		# methop
+    '+',  15,		# unop_aux
 );
 
 my %opflags = (
diff --git a/regen/opcodes b/regen/opcodes
index 62c3b45e70..4731fa7b56 100644
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -14,6 +14,7 @@
 # padop/svop  - $            padop    - # (unused)   loop       - {
 # baseop/unop - %            loopexop - }            filestatop - -
 # pvop/svop   - "            cop      - ;            methop     - .
+# unop_aux    - +
 
 # Other options are:
 #   needs stack mark                    - m  (OA_MARK)