chained comparisons

Author: Zefram

MANIFEST

@@ -5800,6 +5800,7 @@ t/op/chop.t			See if chop works
 t/op/chr.t			See if chr works
 t/op/closure.t			See if closures work
 t/op/closure_test.pl		Extra file for closure.t
+t/op/cmpchain.t			See if comparison chaining works
 t/op/concat2.t			Tests too complex for concat.t
 t/op/cond.t			See if conditional expressions work
 t/op/const-optree.t		Tests for sub(){...} becoming constant

embed.fnc

@@ -1000,6 +1000,10 @@ p	|bool	|io_close	|NN IO* io|NULLOK GV *gv \
 				|bool not_implicit|bool warn_on_fail
 : Used in perly.y
 pR	|OP*	|invert		|NULLOK OP* cmd
+pR	|OP*	|cmpchain_start	|Optype type|NULLOK OP* left \
+				|NULLOK OP* right
+pR	|OP*	|cmpchain_extend|Optype type|NN OP* ch|NULLOK OP* right
+pR	|OP*	|cmpchain_finish|NN OP* ch
 ApR	|I32	|is_lvalue_sub
 : Used in cop.h
 XopR	|I32	|was_lvalue_sub

embed.h

@@ -1262,6 +1262,9 @@
 #define ck_tell(a)		Perl_ck_tell(aTHX_ a)
 #define ck_trunc(a)		Perl_ck_trunc(aTHX_ a)
 #define closest_cop(a,b,c,d)	Perl_closest_cop(aTHX_ a,b,c,d)
+#define cmpchain_extend(a,b,c)	Perl_cmpchain_extend(aTHX_ a,b,c)
+#define cmpchain_finish(a)	Perl_cmpchain_finish(aTHX_ a)
+#define cmpchain_start(a,b,c)	Perl_cmpchain_start(aTHX_ a,b,c)
 #define core_prototype(a,b,c,d)	Perl_core_prototype(aTHX_ a,b,c,d)
 #define coresub_op(a,b,c)	Perl_coresub_op(aTHX_ a,b,c)
 #define create_eval_scope(a,b)	Perl_create_eval_scope(aTHX_ a,b)

ext/Opcode/Opcode.pm

@@ -6,7 +6,7 @@ use strict;
 
 our($VERSION, @ISA, @EXPORT_OK);
 
-$VERSION = "1.45";
+$VERSION = "1.46";
 
 use Carp;
 use Exporter ();
@@ -345,6 +345,8 @@ invert_opset function.
     method_super method_redir method_redir_super
      -- XXX loops via recursion?
 
+    cmpchain_and cmpchain_dup
+
     leaveeval -- needed for Safe to operate, is safe
 		 without entereval
 

lib/B/Deparse.pm

@@ -3200,6 +3200,64 @@ sub pp_andassign { logassignop(@_, "&&=") }
 sub pp_orassign  { logassignop(@_, "||=") }
 sub pp_dorassign { logassignop(@_, "//=") }
 
+my %cmpchain_cmpops = (
+	eq => ["==", 14],
+	i_eq => ["==", 14],
+	ne => ["!=", 14],
+	i_ne => ["!=", 14],
+	seq => ["eq", 14],
+	sne => ["ne", 14],
+	lt => ["<", 15],
+	i_lt => ["<", 15],
+	gt => [">", 15],
+	i_gt => [">", 15],
+	le => ["<=", 15],
+	i_le => ["<=", 15],
+	ge => [">=", 15],
+	i_ge => [">=", 15],
+	slt => ["lt", 15],
+	sgt => ["gt", 15],
+	sle => ["le", 15],
+	sge => ["ge", 15],
+);
+sub pp_cmpchain_and {
+    my($self, $op, $cx) = @_;
+    my($prec, $dep);
+    while(1) {
+	my($thiscmp, $rightcond);
+	if($op->name eq "cmpchain_and") {
+	    $thiscmp = $op->first;
+	    $rightcond = $thiscmp->sibling;
+	} else {
+	    $thiscmp = $op;
+	}
+	my $thiscmptype = $cmpchain_cmpops{$thiscmp->name} // (return "XXX");
+	if(defined $prec) {
+	    $thiscmptype->[1] == $prec or return "XXX";
+	    $thiscmp->first->name eq "null" &&
+		    !($thiscmp->first->flags & OPf_KIDS)
+		or return "XXX";
+	} else {
+	    $prec = $thiscmptype->[1];
+	    $dep = $self->deparse($thiscmp->first, $prec);
+	}
+	$dep .= " ".$thiscmptype->[0]." ";
+	my $operand = $thiscmp->last;
+	if(defined $rightcond) {
+	    $operand->name eq "cmpchain_dup" or return "XXX";
+	    $operand = $operand->first;
+	}
+	$dep .= $self->deparse($operand, $prec);
+	last unless defined $rightcond;
+	if($rightcond->name eq "null" && ($rightcond->flags & OPf_KIDS) &&
+		$rightcond->first->name eq "cmpchain_and") {
+	    $rightcond = $rightcond->first;
+	}
+	$op = $rightcond;
+    }
+    return $self->maybe_parens($dep, $cx, $prec);
+}
+
 sub rv2gv_or_string {
     my($self,$op) = @_;
     if ($op->name eq "gv") { # could be open("open") or open("###")

lib/B/Deparse.t

@@ -3092,3 +3092,30 @@ $r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'};
 $r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'}{'r'};
 $r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'}{'r'}{'s'};
 $r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'}{'r'}{'s'}{'t'};
+####
+# chained comparison
+my($a, $b, $c, $d, $e, $f, $g);
+$a = $b gt $c >= $d;
+$a = $b < $c <= $d > $e;
+$a = $b == $c != $d;
+$a = $b eq $c ne $d == $e;
+$a = $b << $c < $d << $e <= $f << $g;
+$a = int $b < int $c <= int $d;
+$a = ($b < $c) < ($d < $e) <= ($f < $g);
+$a = ($b == $c) < ($d == $e) <= ($f == $g);
+$a = ($b & $c) < ($d & $e) <= ($f & $g);
+$a = $b << $c == $d << $e != $f << $g;
+$a = int $b == int $c != int $d;
+$a = $b < $c == $d < $e != $f < $g;
+$a = ($b == $c) == ($d == $e) != ($f == $g);
+$a = ($b & $c) == ($d & $e) != ($f & $g);
+$a = $b << ($c < $d <= $e);
+$a = int($c < $d <= $e);
+$a = $b < ($c < $d <= $e);
+$a = $b == $c < $d <= $e;
+$a = $b & $c < $d <= $e;
+$a = $b << ($c == $d != $e);
+$a = int($c == $d != $e);
+$a = $b < ($c == $d != $e);
+$a = $b == ($c == $d != $e);
+$a = $b & $c == $d != $e;

lib/B/Op_private.pm

@@ -284,6 +284,8 @@ $bits{chr}{0} = $bf[0];
 $bits{chroot}{0} = $bf[0];
 @{$bits{close}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
 $bits{closedir}{0} = $bf[0];
+$bits{cmpchain_and}{0} = $bf[0];
+$bits{cmpchain_dup}{0} = $bf[0];
 $bits{complement}{0} = $bf[0];
 @{$bits{concat}}{6,1,0} = ('OPpCONCAT_NESTED', $bf[1], $bf[1]);
 $bits{cond_expr}{0} = $bf[0];

op.c

@@ -5499,6 +5499,120 @@ Perl_invert(pTHX_ OP *o)
     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
 }
 
+OP *
+Perl_cmpchain_start(pTHX_ Optype type, OP *left, OP *right)
+{
+    BINOP *bop;
+    OP *op;
+
+    if (!left)
+	left = newOP(OP_NULL, 0);
+    if (!right)
+	right = newOP(OP_NULL, 0);
+    scalar(left);
+    scalar(right);
+    NewOp(0, bop, 1, BINOP);
+    op = (OP*)bop;
+    ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
+    OpTYPE_set(op, type);
+    cBINOPx(op)->op_flags = OPf_KIDS;
+    cBINOPx(op)->op_private = 2;
+    cBINOPx(op)->op_first = left;
+    cBINOPx(op)->op_last = right;
+    OpMORESIB_set(left, right);
+    OpLASTSIB_set(right, op);
+    return op;
+}
+
+OP *
+Perl_cmpchain_extend(pTHX_ Optype type, OP *ch, OP *right)
+{
+    BINOP *bop;
+    OP *op;
+
+    PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
+    if (!right)
+	right = newOP(OP_NULL, 0);
+    scalar(right);
+    NewOp(0, bop, 1, BINOP);
+    op = (OP*)bop;
+    ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
+    OpTYPE_set(op, type);
+    if (ch->op_type != OP_NULL) {
+	UNOP *lch;
+	OP *nch, *cleft, *cright;
+	NewOp(0, lch, 1, UNOP);
+	nch = (OP*)lch;
+	OpTYPE_set(nch, OP_NULL);
+	nch->op_flags = OPf_KIDS;
+	cleft = cBINOPx(ch)->op_first;
+	cright = cBINOPx(ch)->op_last;
+	cBINOPx(ch)->op_first = NULL;
+	cBINOPx(ch)->op_last = NULL;
+	cBINOPx(ch)->op_private = 0;
+	cBINOPx(ch)->op_flags = 0;
+	cUNOPx(nch)->op_first = cright;
+	OpMORESIB_set(cright, ch);
+	OpMORESIB_set(ch, cleft);
+	OpLASTSIB_set(cleft, nch);
+	ch = nch;
+    }
+    OpMORESIB_set(right, op);
+    OpMORESIB_set(op, cUNOPx(ch)->op_first);
+    cUNOPx(ch)->op_first = right;
+    return ch;
+}
+
+OP *
+Perl_cmpchain_finish(pTHX_ OP *ch)
+{
+    PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
+    if (ch->op_type != OP_NULL) {
+	Optype cmpoptype = ch->op_type;
+	ch = CHECKOP(cmpoptype, ch);
+	if(!ch->op_next && ch->op_type == cmpoptype)
+	    ch = fold_constants(op_integerize(op_std_init(ch)));
+	return ch;
+    } else {
+	OP *condop = NULL;
+	OP *rightarg = cUNOPx(ch)->op_first;
+	cUNOPx(ch)->op_first = OpSIBLING(rightarg);
+	OpLASTSIB_set(rightarg, NULL);
+	while (1) {
+	    OP *cmpop = cUNOPx(ch)->op_first;
+	    OP *leftarg = OpSIBLING(cmpop);
+	    Optype cmpoptype = cmpop->op_type;
+	    OP *nextrightarg;
+	    bool is_last;
+	    is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
+	    OpLASTSIB_set(cmpop, NULL);
+	    OpLASTSIB_set(leftarg, NULL);
+	    if (is_last) {
+		ch->op_flags = 0;
+		op_free(ch);
+		nextrightarg = NULL;
+	    } else {
+		nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
+		leftarg = newOP(OP_NULL, 0);
+	    }
+	    cBINOPx(cmpop)->op_first = leftarg;
+	    cBINOPx(cmpop)->op_last = rightarg;
+	    OpMORESIB_set(leftarg, rightarg);
+	    OpLASTSIB_set(rightarg, cmpop);
+	    cmpop->op_flags = OPf_KIDS;
+	    cmpop->op_private = 2;
+	    cmpop = CHECKOP(cmpoptype, cmpop);
+	    if(!cmpop->op_next && cmpop->op_type == cmpoptype)
+		cmpop = fold_constants(op_integerize(op_std_init(cmpop)));
+	    condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
+			cmpop;
+	    if (!nextrightarg)
+		return condop;
+	    rightarg = nextrightarg;
+	}
+    }
+}
+
 /*
 =for apidoc op_scope
 
@@ -17432,6 +17546,7 @@ Perl_rpeep(pTHX_ OP *o)
         case OP_AND:
 	case OP_OR:
 	case OP_DOR:
+	case OP_CMPCHAIN_AND:
 	    while (cLOGOP->op_other->op_type == OP_NULL)
 		cLOGOP->op_other = cLOGOP->op_other->op_next;
 	    while (o->op_next && (   o->op_type == o->op_next->op_type

opcode.h

@@ -544,6 +544,8 @@ EXTCONST char* const PL_op_name[] = {
 	"lvavref",
 	"anonconst",
 	"isa",
+	"cmpchain_and",
+	"cmpchain_dup",
 	"freed",
 };
 #endif
@@ -950,6 +952,8 @@ EXTCONST char* const PL_op_desc[] = {
 	"lvalue array reference",
 	"anonymous constant",
 	"derived class test",
+	"comparison chaining",
+	"comparand shuffling",
 	"freed op",
 };
 #endif
@@ -1368,6 +1372,8 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
 	Perl_pp_lvavref,
 	Perl_pp_anonconst,
 	Perl_pp_isa,
+	Perl_pp_cmpchain_and,
+	Perl_pp_cmpchain_dup,
 }
 #endif
 #ifdef PERL_PPADDR_INITED
@@ -1782,6 +1788,8 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
 	Perl_ck_null,		/* lvavref */
 	Perl_ck_null,		/* anonconst */
 	Perl_ck_isa,		/* isa */
+	Perl_ck_null,		/* cmpchain_and */
+	Perl_ck_null,		/* cmpchain_dup */
 }
 #endif
 #ifdef PERL_CHECK_INITED
@@ -2192,6 +2200,8 @@ EXTCONST U32 PL_opargs[] = {
 	0x00000b40,	/* lvavref */
 	0x00000144,	/* anonconst */
 	0x00000204,	/* isa */
+	0x00000300,	/* cmpchain_and */
+	0x00000100,	/* cmpchain_dup */
 };
 #endif
 
@@ -2861,6 +2871,8 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
      234, /* lvavref */
        0, /* anonconst */
       12, /* isa */
+       0, /* cmpchain_and */
+       0, /* cmpchain_dup */
 
 };
 
@@ -2879,7 +2891,7 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
  */
 
 EXTCONST U16  PL_op_private_bitdefs[] = {
-    0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, argdefelem, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst */
+    0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, argdefelem, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst, cmpchain_and, cmpchain_dup */
     0x2fdc, 0x41b9, /* pushmark */
     0x00bd, /* wantarray, runcv */
     0x0438, 0x1a50, 0x426c, 0x3d28, 0x3505, /* const */
@@ -3355,6 +3367,8 @@ EXTCONST U8 PL_op_private_valid[] = {
     /* LVAVREF    */ (OPpARG1_MASK|OPpPAD_STATE|OPpLVAL_INTRO),
     /* ANONCONST  */ (OPpARG1_MASK),
     /* ISA        */ (OPpARG2_MASK),
+    /* CMPCHAIN_AND */ (OPpARG1_MASK),
+    /* CMPCHAIN_DUP */ (OPpARG1_MASK),
 
 };
 

opnames.h

@@ -412,10 +412,12 @@ typedef enum opcode {
 	OP_LVAVREF	 = 395,
 	OP_ANONCONST	 = 396,
 	OP_ISA		 = 397,
+	OP_CMPCHAIN_AND	 = 398,
+	OP_CMPCHAIN_DUP	 = 399,
 	OP_max		
 } opcode;
 
-#define MAXO 398
+#define MAXO 400
 #define OP_FREED MAXO
 
 /* the OP_IS_* macros are optimized to a simple range check because