This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add protos for positive keywords
authorFather Chrysostomos <sprout@cpan.org>
Sat, 21 Apr 2012 19:50:25 +0000 (12:50 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 29 May 2012 16:36:23 +0000 (09:36 -0700)
‘Positive’ means having a + before it in regen/keywords.pl; i.e., key-
words that cannot be overridden.

Since all keywords are going to be added as subs to the CORE:: name-
space, with prototypes wherever they can apply, it makes sense to
return prototypes for all that can have them, which turns out to be
only a handful.

op.c
pp.c
t/op/cproto.t

diff --git a/op.c b/op.c
index 94b9281..cf2f9fa 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10527,7 +10527,7 @@ Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
 This function assigns the prototype of the named core function to C<sv>, or
 to a new mortal SV if C<sv> is NULL.  It returns the modified C<sv>, or
 NULL if the core function has no prototype.  C<code> is a code as returned
-by C<keyword()>.  It must be negative and unequal to -KEY_CORE.
+by C<keyword()>.  It must not be equal to 0 or -KEY_CORE.
 
 =cut
 */
@@ -10544,19 +10544,24 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
 
     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
 
-    assert (code < 0 && code != -KEY_CORE);
+    assert (code && code != -KEY_CORE);
 
     if (!sv) sv = sv_newmortal();
 
 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
 
-    switch (-code) {
+    switch (code < 0 ? -code : code) {
     case KEY_and   : case KEY_chop: case KEY_chomp:
-    case KEY_cmp   : case KEY_exec: case KEY_eq   :
-    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:
+    case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
+    case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
+    case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
+    case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
+    case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
+    case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
+    case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
+    case KEY_x     : case KEY_xor    :
        if (!opnum) return NULL; nullret = TRUE; goto findopnum;
+    case KEY_glob:    retsetpvs("_;", OP_GLOB);
     case KEY_keys:    retsetpvs("+", OP_KEYS);
     case KEY_values:  retsetpvs("+", OP_VALUES);
     case KEY_each:    retsetpvs("+", OP_EACH);
@@ -10564,8 +10569,10 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
     case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
     case KEY_pop:     retsetpvs(";+", OP_POP);
     case KEY_shift:   retsetpvs(";+", OP_SHIFT);
+    case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
     case KEY_splice:
        retsetpvs("+;$$@", OP_SPLICE);
+    case KEY_undef:   retsetpvs(";\\[$@%&*]", OP_UNDEF);
     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
        retsetpvs("", 0);
     case KEY_evalbytes:
@@ -10586,7 +10593,7 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
        }
        i++;
     }
-    assert(0); return NULL;    /* Should not happen... */
+    return NULL;
   found:
     defgv = PL_opargs[i] & OA_DEFGV;
     oa = PL_opargs[i] >> OASHIFT;
diff --git a/pp.c b/pp.c
index 444489b..4c11588 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -440,7 +440,7 @@ PP(pp_prototype)
            const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
            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;
            }
index a6dc210..85b86db 100644 (file)
@@ -129,7 +129,7 @@ getservent ()
 getsockname (*)
 getsockopt (*$$)
 given undef
-glob undef
+glob (_;)
 gmtime (;$)
 goto undef
 grep undef
@@ -177,10 +177,10 @@ pack ($@)
 package undef
 pipe (**)
 pop (;+)
-pos undef
+pos (;\[$*])
 print undef
 printf undef
-prototype undef
+prototype ($)
 push (+@)
 q undef
 qq undef
@@ -207,7 +207,7 @@ rindex ($$;$)
 rmdir (_)
 s undef
 say undef
-scalar undef
+scalar ($)
 seek (*$$)
 seekdir (*$)
 select undef
@@ -242,7 +242,7 @@ sqrt (_)
 srand (;$)
 stat (;*)
 state undef
-study undef
+study (_)
 sub undef
 substr ($$;$$)
 symlink ($$)
@@ -263,7 +263,7 @@ truncate ($$)
 uc (_)
 ucfirst (_)
 umask (;$)
-undef undef
+undef (;\[$@%&*])
 unless undef
 unlink (@)
 unpack ($_)