This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move pp_-specific code out of core_prototype
authorFather Chrysostomos <sprout@cpan.org>
Tue, 9 Aug 2011 06:57:01 +0000 (23:57 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sun, 14 Aug 2011 19:54:05 +0000 (12:54 -0700)
Commit b8c38f0a2a65 refactored pp_prototype by moving much of its
code to a new function in op.c, called core_prototype.  This served
two purposes: (1) to allow the code to be simplified, which required
the use of static functions in op.c, and (2) to allow the &CORE::subs
feature to share the same code.

But some code was moved to core_prototype which, in hindsight, did not
need to be moved, such as the ‘Can’t find an opnumber’ message.

This commit moves that code back to pp_prototype, resulting in a sim-
pler (and possibly faster, at least for &CORE::subs) core_prototype.

embed.fnc
embed.h
gv.c
op.c
pp.c
proto.h

index 5502c32..e7041b1 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -265,8 +265,7 @@ Afnp        |int    |printf_nocontext|NN const char *format|...
 #endif
 : Used in pp.c
 p      |SV *   |core_prototype |NULLOK SV *sv|NN const char *name \
-                               |const int code|NULLOK int * const opnum\
-                               |const bool croak
+                               |const int code|NULLOK int * const opnum
 : Used in sv.c
 p      |void   |cv_ckproto_len |NN const CV* cv|NULLOK const GV* gv\
                                |NULLOK const char* p|const STRLEN len
diff --git a/embed.h b/embed.h
index 1646565..7fc3b21 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define ck_trunc(a)            Perl_ck_trunc(aTHX_ a)
 #define ck_unpack(a)           Perl_ck_unpack(aTHX_ a)
 #define convert(a,b,c)         Perl_convert(aTHX_ a,b,c)
-#define core_prototype(a,b,c,d,e)      Perl_core_prototype(aTHX_ a,b,c,d,e)
+#define core_prototype(a,b,c,d)        Perl_core_prototype(aTHX_ a,b,c,d)
 #define create_eval_scope(a)   Perl_create_eval_scope(aTHX_ a)
 #define cv_ckproto_len(a,b,c,d)        Perl_cv_ckproto_len(aTHX_ a,b,c,d)
 #define cvgv_set(a,b)          Perl_cvgv_set(aTHX_ a,b)
diff --git a/gv.c b/gv.c
index d009850..1741bda 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1361,7 +1361,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            CvFILE(cv) = (char *)file;
            CvISXSUB_on(cv);
            CvXSUB(cv) = core_xsub;
-           (void)core_prototype((SV *)cv, name, code, &opnum, 0);
+           (void)core_prototype((SV *)cv, name, code, &opnum);
            opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
            cv_set_call_checker(
               cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
diff --git a/op.c b/op.c
index 4cc0f70..d4d89e4 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10343,7 +10343,7 @@ returns NULL if C<croak> is false.
 
 SV *
 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
-                          int * const opnum, const bool croak)
+                          int * const opnum)
 {
     int i = 0, n = 0, seen_question = 0, defgv = 0;
     I32 oa;
@@ -10353,15 +10353,7 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
 
     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
 
-    if (!code || code == -KEY_CORE) {
-       if (croak)
-           return (SV *)Perl_die(aTHX_
-               "Can't find an opnumber for \"%s\"", name
-           );
-       return NULL;
-    }
-
-    if (code > 0) return NULL; /* Not overridable */
+    assert (code < 0 && code != -KEY_CORE);
 
     if (!sv) sv = sv_newmortal();
 
diff --git a/pp.c b/pp.c
index c6f8eac..ca94935 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -439,9 +439,12 @@ PP(pp_prototype)
        const char * s = SvPVX_const(TOPs);
        if (strnEQ(s, "CORE::", 6)) {
            const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
-           SV *const sv =
-               core_prototype(NULL, s + 6, code, NULL, 1);
-           if (sv) ret = sv;
+           if (!code || code == -KEY_CORE)
+               DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
+           if (code < 0) {     /* Overridable. */
+               SV * const sv = core_prototype(NULL, s + 6, code, NULL);
+               if (sv) ret = sv;
+           }
            goto set;
        }
     }
diff --git a/proto.h b/proto.h
index 398df4c..814b710 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -578,7 +578,7 @@ PERL_CALLCONV void  Perl_cop_store_label(pTHX_ COP *const cop, const char *label,
 #define PERL_ARGS_ASSERT_COP_STORE_LABEL       \
        assert(cop); assert(label)
 
-PERL_CALLCONV SV *     Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, int * const opnum, const bool croak)
+PERL_CALLCONV SV *     Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, int * const opnum)
                        __attribute__nonnull__(pTHX_2);
 #define PERL_ARGS_ASSERT_CORE_PROTOTYPE        \
        assert(name)