This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add LINKLIST to the API.
authorBen Morrow <ben@morrow.me.uk>
Mon, 11 Oct 2010 05:19:44 +0000 (06:19 +0100)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 12 Oct 2010 19:52:12 +0000 (12:52 -0700)
Also rename the underlying function to op_linklist, to match the other
API op functions.

embed.fnc
embed.h
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/op_list.t
global.sym
op.c
op.h
proto.h

index 4ef49ba..e111448 100644 (file)
--- 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 72c16a4..f186c99 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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)
 #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)
index cadfaa4..e39281f 100644 (file)
@@ -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;
index e5b55a9..c7b990a 100644 (file)
@@ -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;
index 11a2961..d888892 100644 (file)
@@ -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 ee2c9f3..aa33ba2 100644 (file)
--- 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 71bab3e..5135ff0 100644 (file)
--- 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 45483e9..aff9574 100644 (file)
--- 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);