Make core_prototype provide the op number as well

Since it has to calculate it, it might as well provide it, so callers
do not have to go through that while(i < MAXO) loop yet again.

(The &CORE::foo feature will use this.)

diff --git a/embed.fnc b/embed.fnc
index 4da1d75..04f8551 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -265,7 +265,8 @@ 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 STRLEN len|const bool croak
+                               |const STRLEN len|NULLOK int * const opnum\
+                               |const bool croak
 : 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 7fc3b21..1646565 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1008,7 +1008,7 @@
 #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)        Perl_core_prototype(aTHX_ a,b,c,d)
+#define core_prototype(a,b,c,d,e)      Perl_core_prototype(aTHX_ a,b,c,d,e)
 #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/op.c b/op.c
index 1f6743d..3f8f7c4 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10254,13 +10254,14 @@ returns NULL if C<croak> is false.
 
 SV *
 Perl_core_prototype(pTHX_ SV *sv, const char *name, const STRLEN len,
-                          const bool croak)
+                          int * const opnum, const bool croak)
 {
     const int code = keyword(name, len, 1);
     int i = 0, n = 0, seen_question = 0, defgv = 0;
     I32 oa;
 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
+    bool nullret = FALSE;
 
     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
 
@@ -10276,7 +10277,7 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const STRLEN len,
 
     if (!sv) sv = sv_newmortal();
 
-#define retsetpvs(x) sv_setpvs(sv, x); return sv
+#define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
 
     switch (-code) {
     case KEY_and   : case KEY_chop: case KEY_chomp:
@@ -10284,27 +10285,30 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const STRLEN len,
     case KEY_ge    : case KEY_gt  : case KEY_le   :
     case KEY_lt    : case KEY_ne  : case KEY_or   :
     case KEY_select: case KEY_system: case KEY_x  : case KEY_xor:
-       return NULL;
-    case KEY_keys: case KEY_values: case KEY_each:
-       retsetpvs("+");
-    case KEY_push: case KEY_unshift:
-       retsetpvs("+@");
-    case KEY_pop: case KEY_shift:
-       retsetpvs(";+");
+       if (!opnum) return NULL; nullret = TRUE; goto findopnum;
+    case KEY_keys:    retsetpvs("+", OP_KEYS);
+    case KEY_values:  retsetpvs("+", OP_VALUES);
+    case KEY_each:    retsetpvs("+", OP_EACH);
+    case KEY_push:    retsetpvs("+@", OP_PUSH);
+    case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
+    case KEY_pop:     retsetpvs(";+", OP_POP);
+    case KEY_shift:   retsetpvs(";+", OP_SHIFT);
     case KEY_splice:
-       retsetpvs("+;$$@");
+       retsetpvs("+;$$@", OP_SPLICE);
     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
-       retsetpvs("");
+       retsetpvs("", 0);
     case KEY_readpipe:
        name = "backtick";
     }
 
 #undef retsetpvs
 
+  findopnum:
     while (i < MAXO) { /* The slow way. */
        if (strEQ(name, PL_op_name[i])
            || strEQ(name, PL_op_desc[i]))
        {
+           if (nullret) { assert(opnum); *opnum = i; return NULL; }
            goto found;
        }
        i++;
@@ -10343,6 +10347,7 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const STRLEN len,
        str[0] = '_';
     str[n++] = '\0';
     sv_setpvn(sv, str, n - 1);
+    if (opnum) *opnum = i;
     return sv;
 }
 

diff --git a/pp.c b/pp.c
index 8649bec..a32d0c0 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -438,7 +438,8 @@ PP(pp_prototype)
     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
        const char * s = SvPVX_const(TOPs);
        if (strnEQ(s, "CORE::", 6)) {
-           SV *const sv = core_prototype(NULL, s + 6, SvCUR(TOPs) - 6, 1);
+           SV *const sv =
+               core_prototype(NULL, s + 6, SvCUR(TOPs) - 6, NULL, 1);
            if (sv) ret = sv;
            goto set;
        }

diff --git a/proto.h b/proto.h
index b267253..735f0cb 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -571,7 +571,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 STRLEN len, const bool croak)
+PERL_CALLCONV SV *     Perl_core_prototype(pTHX_ SV *sv, const char *name, const STRLEN len, int * const opnum, const bool croak)
                        __attribute__nonnull__(pTHX_2);
 #define PERL_ARGS_ASSERT_CORE_PROTOTYPE        \
        assert(name)