Add LINKLIST to the API.

Also rename the underlying function to op_linklist, to match the other
API op functions.

8 files changed, 162 insertions, 19 deletions

diff --git a/embed.fnc b/embed.fnc
index 4ef49baf28..e11144892b 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -175,6 +175,7 @@ Ap	|int	|Gv_AMupdate	|NN HV* stash|bool destructing
 ApR	|CV*	|gv_handler	|NULLOK HV* stash|I32 id
 Apd	|OP*	|op_append_elem	|I32 optype|NULLOK OP* first|NULLOK OP* last
 Apd	|OP*	|op_append_list	|I32 optype|NULLOK OP* first|NULLOK OP* last
+Apd	|OP*	|op_linklist	|NN OP *o
 Apd	|OP*	|op_prepend_elem|I32 optype|NULLOK OP* first|NULLOK OP* last
 : FIXME - this is only called by pp_chown. They should be merged.
 p	|I32	|apply		|I32 type|NN SV** mark|NN SV** sp
@@ -637,7 +638,6 @@ EXp	|void	|op_clear	|NN OP* o
 Ap	|void	|op_refcnt_lock
 Ap	|void	|op_refcnt_unlock
 #if defined(PERL_IN_OP_C)
-s	|OP*	|linklist	|NN OP *o
 s	|OP*	|listkids	|NULLOK OP* o
 #endif
 : Used in S_doeval in pp_ctl.c
diff --git a/embed.h b/embed.h
index 72c16a431c..f186c99d58 100644
--- a/embed.h
+++ b/embed.h
@@ -369,6 +369,7 @@
 #define op_contextualize(a,b)	Perl_op_contextualize(aTHX_ a,b)
 #define op_dump(a)		Perl_op_dump(aTHX_ a)
 #define op_free(a)		Perl_op_free(aTHX_ a)
+#define op_linklist(a)		Perl_op_linklist(aTHX_ a)
 #define op_null(a)		Perl_op_null(aTHX_ a)
 #define op_prepend_elem(a,b,c)	Perl_op_prepend_elem(aTHX_ a,b,c)
 #define op_refcnt_lock()	Perl_op_refcnt_lock(aTHX)
@@ -1639,7 +1640,6 @@
 #define is_handle_constructor	S_is_handle_constructor
 #define is_inplace_av(a,b)	S_is_inplace_av(aTHX_ a,b)
 #define is_list_assignment(a)	S_is_list_assignment(aTHX_ a)
-#define linklist(a)		S_linklist(aTHX_ a)
 #define listkids(a)		S_listkids(aTHX_ a)
 #define looks_like_bool(a)	S_looks_like_bool(aTHX_ a)
 #define modkids(a,b)		S_modkids(aTHX_ a,b)
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index cadfaa4896..e39281fccd 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -448,6 +448,66 @@ test_op_list_describe(OP *o)
     return SvPVX(res);
 }
 
+/* the real new*OP functions have a tendancy to call fold_constants, and
+ * other such unhelpful things, so we need our own versions for testing */
+
+#define mkUNOP(t, f) THX_mkUNOP(aTHX_ (t), (f))
+static OP *
+THX_mkUNOP(pTHX_ U32 type, OP *first)
+{
+    UNOP *unop;
+    NewOp(1103, unop, 1, UNOP);
+    unop->op_type   = (OPCODE)type;
+    unop->op_first  = first;
+    unop->op_flags  = OPf_KIDS;
+    return (OP *)unop;
+}
+
+#define mkBINOP(t, f, l) THX_mkBINOP(aTHX_ (t), (f), (l))
+static OP *
+THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last)
+{
+    BINOP *binop;
+    NewOp(1103, binop, 1, BINOP);
+    binop->op_type      = (OPCODE)type;
+    binop->op_first     = first;
+    binop->op_flags     = OPf_KIDS;
+    binop->op_last      = last;
+    first->op_sibling   = last;
+    return (OP *)binop;
+}
+
+#define mkLISTOP(t, f, s, l) THX_mkLISTOP(aTHX_ (t), (f), (s), (l))
+static OP *
+THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last)
+{
+    LISTOP *listop;
+    NewOp(1103, listop, 1, LISTOP);
+    listop->op_type     = (OPCODE)type;
+    listop->op_flags    = OPf_KIDS;
+    listop->op_first    = first;
+    first->op_sibling   = sib;
+    sib->op_sibling     = last;
+    listop->op_last     = last;
+    return (OP *)listop;
+}
+
+static char *
+test_op_linklist_describe(OP *start)
+{
+    SV *rv = sv_2mortal(newSVpvs(""));
+    OP *o;
+    o = start = LINKLIST(start);
+    do {
+        sv_catpvs(rv, ".");
+        sv_catpv(rv, OP_NAME(o));
+        if (o->op_type == OP_CONST)
+            sv_catsv(rv, cSVOPo->op_sv);
+        o = o->op_next;
+    } while (o && o != start);
+    return SvPVX(rv);
+}
+
 /** RPN keyword parser **/
 
 #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
@@ -1932,10 +1992,63 @@ test_op_list()
 	check_op(a, "lineseq[list[pushmark.const(1).const(2).]"
 		"const(3).const(4).]");
 	op_free(a);
-#undef iv_op
 #undef check_op
 
 void
+test_op_linklist ()
+    PREINIT:
+        OP *o;
+    CODE:
+#define check_ll(o, expect) \
+    STMT_START { \
+	if (strNE(test_op_linklist_describe(o), (expect))) \
+	    croak("fail %s %s", test_op_linklist_describe(o), (expect)); \
+    } STMT_END
+        o = iv_op(1);
+        check_ll(o, ".const1");
+        op_free(o);
+
+        o = mkUNOP(OP_NOT, iv_op(1));
+        check_ll(o, ".const1.not");
+        op_free(o);
+
+        o = mkUNOP(OP_NOT, mkUNOP(OP_NEGATE, iv_op(1)));
+        check_ll(o, ".const1.negate.not");
+        op_free(o);
+
+        o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
+        check_ll(o, ".const1.const2.add");
+        op_free(o);
+
+        o = mkBINOP(OP_ADD, mkUNOP(OP_NOT, iv_op(1)), iv_op(2));
+        check_ll(o, ".const1.not.const2.add");
+        op_free(o);
+
+        o = mkUNOP(OP_NOT, mkBINOP(OP_ADD, iv_op(1), iv_op(2)));
+        check_ll(o, ".const1.const2.add.not");
+        op_free(o);
+
+        o = mkLISTOP(OP_LINESEQ, iv_op(1), iv_op(2), iv_op(3));
+        check_ll(o, ".const1.const2.const3.lineseq");
+        op_free(o);
+
+        o = mkLISTOP(OP_LINESEQ,
+                mkBINOP(OP_ADD, iv_op(1), iv_op(2)),
+                mkUNOP(OP_NOT, iv_op(3)),
+                mkLISTOP(OP_SUBSTR, iv_op(4), iv_op(5), iv_op(6)));
+        check_ll(o, ".const1.const2.add.const3.not"
+                    ".const4.const5.const6.substr.lineseq");
+        op_free(o);
+
+        o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
+        LINKLIST(o);
+        o = mkBINOP(OP_SUBTRACT, o, iv_op(3));
+        check_ll(o, ".const1.const2.add.const3.subtract");
+        op_free(o);
+#undef check_ll
+#undef iv_op
+
+void
 peep_enable ()
     PREINIT:
 	dMY_CXT;
diff --git a/ext/XS-APItest/t/op_list.t b/ext/XS-APItest/t/op_list.t
index e5b55a93c9..c7b990a7f0 100644
--- a/ext/XS-APItest/t/op_list.t
+++ b/ext/XS-APItest/t/op_list.t
@@ -1,10 +1,13 @@
 use warnings;
 use strict;
-use Test::More tests => 1;
+use Test::More tests => 2;
 
 use XS::APItest;
 
 XS::APItest::test_op_list();
 ok 1;
 
+XS::APItest::test_op_linklist();
+ok 1;
+
 1;
diff --git a/global.sym b/global.sym
index 11a2961518..d88889202f 100644
--- a/global.sym
+++ b/global.sym
@@ -414,6 +414,7 @@ Perl_op_clear
 Perl_op_contextualize
 Perl_op_dump
 Perl_op_free
+Perl_op_linklist
 Perl_op_null
 Perl_op_prepend_elem
 Perl_op_refcnt_lock
diff --git a/op.c b/op.c
index ee2c9f376e..aa33ba295c 100644
--- a/op.c
+++ b/op.c
@@ -843,14 +843,22 @@ Perl_op_contextualize(pTHX_ OP *o, I32 context)
     }
 }
 
-#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
+/*
+=head1 Optree Manipulation Functions
 
-static OP *
-S_linklist(pTHX_ OP *o)
+=for apidoc Am|OP*|op_linklist|OP *o
+This function is the implementation of the L</LINKLIST> macro. It should
+not be called directly.
+
+=cut
+*/
+
+OP *
+Perl_op_linklist(pTHX_ OP *o)
 {
     OP *first;
 
-    PERL_ARGS_ASSERT_LINKLIST;
+    PERL_ARGS_ASSERT_OP_LINKLIST;
 
     if (o->op_next)
 	return o->op_next;
@@ -2417,7 +2425,10 @@ Perl_newPROG(pTHX_ OP *o)
 	PL_eval_root = newUNOP(OP_LEAVEEVAL,
 			       ((PL_in_eval & EVAL_KEEPERR)
 				? OPf_SPECIAL : 0), o);
-	PL_eval_start = linklist(PL_eval_root);
+	/* don't use LINKLIST, since PL_eval_root might indirect through
+	 * a rather expensive function call and LINKLIST evaluates its
+	 * argument more than once */
+	PL_eval_start = op_linklist(PL_eval_root);
 	PL_eval_root->op_private |= OPpREFCOUNTED;
 	OpREFCNT_set(PL_eval_root, 1);
 	PL_eval_root->op_next = 0;
@@ -2703,7 +2714,7 @@ S_gen_constant_list(pTHX_ register OP *o)
 #else
     op_free(curop);
 #endif
-    linklist(o);
+    LINKLIST(o);
     return list(o);
 }
 
@@ -5180,7 +5191,7 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
     flip = newUNOP(OP_FLIP, flags, (OP*)range);
     flop = newUNOP(OP_FLOP, 0, flip);
     o = newUNOP(OP_NULL, 0, flop);
-    linklist(flop);
+    LINKLIST(flop);
     range->op_next = leftstart;
 
     left->op_next = flip;
@@ -5196,7 +5207,7 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
 
     flip->op_next = o;
     if (!flip->op_private || !flop->op_private)
-	linklist(o);		/* blow off optimizer unless constant */
+	LINKLIST(o);		/* blow off optimizer unless constant */
 
     return o;
 }
@@ -7434,7 +7445,7 @@ Perl_ck_fun(pTHX_ OP *o)
 		{
 		    OP * const newop = newUNOP(OP_NULL, 0, kid);
 		    kid->op_sibling = 0;
-		    linklist(kid);
+		    LINKLIST(kid);
 		    newop->op_next = newop;
 		    kid = newop;
 		    kid->op_sibling = sibl;
@@ -8263,7 +8274,7 @@ Perl_ck_sort(pTHX_ OP *o)
 	OP *kid = cUNOPx(firstkid)->op_first;		/* get past null */
 
 	if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
-	    linklist(kid);
+	    LINKLIST(kid);
 	    if (kid->op_type == OP_SCOPE) {
 		k = kid->op_next;
 		kid->op_next = 0;
diff --git a/op.h b/op.h
index 71bab3e3b3..5135ff0c24 100644
--- a/op.h
+++ b/op.h
@@ -622,6 +622,21 @@ struct loop {
 #define ref(o, type) doref(o, type, TRUE)
 #endif
 
+/*
+=head1 Optree Manipulation Functions
+
+=for apidoc Am|OP*|LINKLIST|OP *o
+Given the root of an optree, link the tree in execution order using the
+C<op_next> pointers and return the first op executed. If this has
+already been done, it will not be redone, and C<< o->op_next >> will be
+returned. If C<< o->op_next >> is not already set, I<o> should be at
+least an C<UNOP>.
+
+=cut
+*/
+
+#define LINKLIST(o) ((o)->op_next ? (o)->op_next : op_linklist((OP*)o))
+
 /* no longer used anywhere in core */
 #ifndef PERL_CORE
 #define cv_ckproto(cv, gv, p) \
diff --git a/proto.h b/proto.h
index 45483e999e..aff9574dfc 100644
--- a/proto.h
+++ b/proto.h
@@ -2694,6 +2694,11 @@ PERL_CALLCONV void	Perl_op_dump(pTHX_ const OP *o)
 	assert(o)
 
 PERL_CALLCONV void	Perl_op_free(pTHX_ OP* arg);
+PERL_CALLCONV OP*	Perl_op_linklist(pTHX_ OP *o)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OP_LINKLIST	\
+	assert(o)
+
 PERL_CALLCONV void	Perl_op_null(pTHX_ OP* o)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_OP_NULL	\
@@ -5689,11 +5694,6 @@ STATIC OP*	S_is_inplace_av(pTHX_ OP* o, OP* oright)
 STATIC I32	S_is_list_assignment(pTHX_ const OP *o)
 			__attribute__warn_unused_result__;
 
-STATIC OP*	S_linklist(pTHX_ OP *o)
-			__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_LINKLIST	\
-	assert(o)
-
 STATIC OP*	S_listkids(pTHX_ OP* o);
 STATIC bool	S_looks_like_bool(pTHX_ const OP* o)
 			__attribute__nonnull__(pTHX_1);