summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJesse Vincent <jesse@bestpractical.com>2009-11-05 11:14:45 -0500
committerJesse Vincent <jesse@bestpractical.com>2009-11-05 11:14:45 -0500
commit88e1f1a2657a3a28cf3a7811902a09aca9e18986 (patch)
treee7280ddd6c04915543c3850e403d06b8b5892524
parent9b583d5830e4b19cc53ab2180c0fd30418e764ed (diff)
downloadperl-88e1f1a2657a3a28cf3a7811902a09aca9e18986.tar.gz
Implement facility to plug in syntax triggered by keywords
Date: Tue, 27 Oct 2009 01:29:40 +0000 From: Zefram <zefram@fysh.org> To: perl5-porters@perl.org Subject: bareword sub lookups Attached is a patch that changes how the tokeniser looks up subroutines, when they're referenced by a bareword, for prototype and const-sub purposes. Formerly, it has looked up bareword subs directly in the package, which is contrary to the way the generated op tree looks up the sub, via an rv2cv op. The patch makes the tokeniser generate the rv2cv op earlier, and dig around in that. The motivation for this is to allow modules to hook the rv2cv op creation, to affect the name->subroutine lookup process. Currently, such hooking affects op execution as intended, but everything goes wrong with a bareword ref where the tokeniser looks at some unrelated CV, or a blank space, in the package. With the patch in place, an rv2cv hook correctly affects the tokeniser and therefore the prototype-based aspects of parsing. The patch also changes ck_subr (which applies the argument context and checking parts of prototype behaviour) to handle subs referenced by an RV const op inside the rv2cv, where formerly it would only handle a gv op inside the rv2cv. This is to support the most likely kind of modified rv2cv op. [This commit includes the Makefile.PL for XS-APITest-KeywordRPN missing from the original patch, as well as updates to perldiag.pod and a MANIFEST sort]
-rwxr-xr-xConfigure7
-rw-r--r--Cross/config.sh-arm-linux6
-rw-r--r--Cross/config.sh-arm-linux-n7706
-rw-r--r--MANIFEST5
-rw-r--r--NetWare/Makefile12
-rwxr-xr-xPorting/Maintainers.pl8
-rw-r--r--Porting/config.sh6
-rw-r--r--djgpp/config.over1
-rw-r--r--embed.fnc2
-rw-r--r--ext/XS-APItest-KeywordRPN/KeywordRPN.pm146
-rw-r--r--ext/XS-APItest-KeywordRPN/KeywordRPN.xs283
-rw-r--r--ext/XS-APItest-KeywordRPN/Makefile.PL17
-rw-r--r--ext/XS-APItest-KeywordRPN/README25
-rw-r--r--ext/XS-APItest-KeywordRPN/t/keyword_plugin.t76
-rw-r--r--perl.h5
-rw-r--r--perlvars.h68
-rw-r--r--perly.y4
-rw-r--r--plan9/config_sh.sample2
-rw-r--r--pod/perl5112delta.pod22
-rw-r--r--pod/perldiag.pod5
-rw-r--r--pod/perlfunc.pod8
-rw-r--r--pod/perlsyn.pod8
-rw-r--r--symbian/install.cfg1
-rw-r--r--toke.c75
-rw-r--r--utils/perlivp.PL1
25 files changed, 768 insertions, 31 deletions
diff --git a/Configure b/Configure
index a4c33976d0..2c0597f749 100755
--- a/Configure
+++ b/Configure
@@ -21836,6 +21836,13 @@ for xxx in $known_extensions ; do
$define) avail_ext="$avail_ext $xxx" ;;
esac
;;
+ XS/APItest/KeywordRPN|xs/apitest/keywordrpn)
+ # This is just for testing. Skip it unless we have dynamic loading.
+
+ case "$usedl" in
+ $define) avail_ext="$avail_ext $xxx" ;;
+ esac
+ ;;
XS/Typemap|xs/typemap)
# This is just for testing. Skip it unless we have dynamic loading.
case "$usedl" in
diff --git a/Cross/config.sh-arm-linux b/Cross/config.sh-arm-linux
index 4a903a2510..61011ab408 100644
--- a/Cross/config.sh-arm-linux
+++ b/Cross/config.sh-arm-linux
@@ -546,7 +546,7 @@ doublesize='8'
drand01='drand48()'
drand48_r_proto='0'
dtrace=''
-dynamic_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared'
+dynamic_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared'
eagain='EAGAIN'
ebcdic='undef'
echo='echo'
@@ -561,7 +561,7 @@ endservent_r_proto='0'
eunicefix=':'
exe_ext=''
expr='expr'
-extensions='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared Errno'
+extensions='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared Errno'
extras=''
fflushNULL='define'
fflushall='undef'
@@ -751,7 +751,7 @@ issymlink='/usr/bin/test -h'
ivdformat='"ld"'
ivsize='4'
ivtype='long'
-known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared'
+known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared'
ksh=''
ld='cc'
lddlflags='-shared -L/usr/local/lib'
diff --git a/Cross/config.sh-arm-linux-n770 b/Cross/config.sh-arm-linux-n770
index 3e5ebdd1fe..d65aabad8d 100644
--- a/Cross/config.sh-arm-linux-n770
+++ b/Cross/config.sh-arm-linux-n770
@@ -531,7 +531,7 @@ dlsrc='dl_dlopen.xs'
doublesize='8'
drand01='drand48()'
drand48_r_proto='0'
-dynamic_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared'
+dynamic_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared'
eagain='EAGAIN'
ebcdic='undef'
echo='echo'
@@ -546,7 +546,7 @@ endservent_r_proto='0'
eunicefix=':'
exe_ext=''
expr='expr'
-extensions='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared Errno'
+extensions='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared Errno'
extras=''
fflushNULL='define'
fflushall='undef'
@@ -736,7 +736,7 @@ issymlink='/usr/bin/test -h'
ivdformat='"ld"'
ivsize='4'
ivtype='long'
-known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared'
+known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared'
ksh=''
ld='arm-none-linux-gnueabi-gcc'
lddlflags='-shared -L/usr/local/lib'
diff --git a/MANIFEST b/MANIFEST
index 44b1bdea78..e40c3447e1 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3198,6 +3198,11 @@ ext/XS-APItest/APItest.xs XS::APItest extension
ext/XS-APItest/core.c Test API functions when PERL_CORE is defined
ext/XS-APItest/core_or_not.inc Code common to core.c and notcore.c
ext/XS-APItest/exception.c XS::APItest extension
+ext/XS-APItest-KeywordRPN/KeywordRPN.pm XS::APItest::KeywordRPN extension
+ext/XS-APItest-KeywordRPN/KeywordRPN.xs XS::APItest::KeywordRPN extension
+ext/XS-APItest-KeywordRPN/Makefile.PL XS::APItest::KeywordRPN extension
+ext/XS-APItest-KeywordRPN/README XS::APItest::KeywordRPN extension
+ext/XS-APItest-KeywordRPN/t/keyword_plugin.t test keyword plugin mechanism
ext/XS-APItest/Makefile.PL XS::APItest extension
ext/XS-APItest/MANIFEST XS::APItest extension
ext/XS-APItest/notcore.c Test API functions when PERL_CORE is not defined
diff --git a/NetWare/Makefile b/NetWare/Makefile
index 20e99ff800..280711150a 100644
--- a/NetWare/Makefile
+++ b/NetWare/Makefile
@@ -326,6 +326,7 @@ STORABLE_NLM = $(EXTDIR)\Storable\Storable.NLM
LISTUTIL_NLM = $(EXTDIR)\List\Util.NLM
MIMEBASE64_NLM = $(EXTDIR)\MIME\Base64\Base64.NLM
XSAPITEST_NLM = $(EXTDIR)\XS\APItest\APItest.NLM
+XSAPITESTKEYWORDRPN_NLM = $(EXTDIR)\XS\APItest\KeywordRPN\KeywordRPN.NLM
XSTYPEMAP_NLM = $(EXTDIR)\XS\Typemap\Typemap.NLM
UNICODENORMALIZE_NLM = $(EXTDIR)\Unicode\Normalize\Normalize.NLM
@@ -350,6 +351,7 @@ EXTENSION_NLM = \
$(LISTUTIL_NLM) \
$(MIMEBASE64_NLM) \
$(XSAPITEST_NLM) \
+ $(XSAPITESTKEYWORDRPN_NLM) \
$(XSTYPEMAP_NLM) \
$(UNICODENORMALIZE_NLM) \
$(FILTER_NLM)
@@ -789,7 +791,7 @@ X2P_OBJ = $(X2P_SRC:.c=.obj)
DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attributes B re \
Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob \
- Storable/Storable List/Util MIME/Base64/Base64 XS/APItest/APItest \
+ Storable/Storable List/Util MIME/Base64/Base64 XS/APItest/APItest XS/APItest/KeywordRPN \
XS/Typemap/Typemap Unicode/Normalize/Normalize Sys/Hostname
STATIC_EXT = DynaLoader
@@ -817,6 +819,7 @@ STORABLE = $(EXTDIR)\Storable\Storable
LISTUTIL = $(EXTDIR)\List\Util
MIMEBASE64 = $(EXTDIR)\MIME\Base64\Base64
XSAPITEST = $(EXTDIR)\XS\APItest\APItest
+XSAPITESTKEYWORDRPN = $(EXTDIR)\XS\APItest\KeywordRPN\KeywordRPN
XSTYPEMAP = $(EXTDIR)\XS\Typemap\Typemap
UNICODENORMALIZE = $(EXTDIR)\Unicode\Normalize\Normalize
@@ -843,6 +846,7 @@ EXTENSION_C = \
$(LISTUTIL).c \
$(MIMEBASE64).c \
$(XSAPITEST).c \
+ $(XSAPITESTKEYWORDRPN).c \
$(XSTYPEMAP).c \
$(UNICODENORMALIZE).c \
@@ -1267,6 +1271,12 @@ $(XSAPITEST_NLM):
$(MAKE)
cd ..\..\..\netware
+$(XSAPITESTKEYWORDRPN_NLM):
+ cd $(EXTDIR)\XS\$(*B)
+ ..\..\..\miniperl -I..\..\lib Makefile.PL PERL_CORE=1 INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\..\netware
+
$(XSTYPEMAP_NLM):
cd $(EXTDIR)\XS\$(*B)
..\..\..\miniperl -I..\..\lib Makefile.PL PERL_CORE=1 INSTALLDIRS=perl
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index f72f3e1c7b..1703d2598a 100755
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -1734,6 +1734,14 @@ use File::Glob qw(:case);
'UPSTREAM' => 'cpan',
},
+ 'XS::APItest::KeywordRPN' =>
+ {
+ 'MAINTAINER' => 'zefram',
+ 'FILES' => q[ext/XS-APItest-KeywordRPN],
+ 'CPAN' => 0,
+ 'UPSTREAM' => 'blead',
+ },
+
'XSLoader' =>
{
'MAINTAINER' => 'saper',
diff --git a/Porting/config.sh b/Porting/config.sh
index b958755cb1..c18faa4876 100644
--- a/Porting/config.sh
+++ b/Porting/config.sh
@@ -560,7 +560,7 @@ doublesize='8'
drand01='drand48()'
drand48_r_proto='0'
dtrace=''
-dynamic_ext='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize XS/APItest XS/Typemap threads/shared Hash/Util/FieldHash'
+dynamic_ext='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap threads/shared Hash/Util/FieldHash'
eagain='EAGAIN'
ebcdic='undef'
echo='echo'
@@ -575,7 +575,7 @@ endservent_r_proto='0'
eunicefix=':'
exe_ext=''
expr='expr'
-extensions='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize XS/APItest XS/Typemap threads/shared Hash/Util/FieldHash Compress/Zlib Errno IO_Compress_Base IO_Compress_Zlib Module/Pluggable Test/Harness'
+extensions='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap threads/shared Hash/Util/FieldHash Compress/Zlib Errno IO_Compress_Base IO_Compress_Zlib Module/Pluggable Test/Harness'
extern_C='extern'
extras=''
fflushNULL='define'
@@ -767,7 +767,7 @@ issymlink='test -h'
ivdformat='"Ld"'
ivsize='8'
ivtype='long long'
-known_extensions='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize Win32 Win32API/File Win32CORE XS/APItest XS/Typemap threads/shared Hash/Util/FieldHash'
+known_extensions='attributes B Compress/Raw/Zlib Cwd Data/Dumper DB_File Devel/DProf Devel/Peek Devel/PPPort Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util I18N/Langinfo IO IPC/SysV List/Util Math/BigInt/FastCalc MIME/Base64 NDBM_File ODBM_File Opcode PerlIO/encoding PerlIO/scalar PerlIO/via POSIX re SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex threads Time/HiRes Time/Piece Unicode/Normalize Win32 Win32API/File Win32CORE XS/APItest XS/APItest/KeywordRPN XS/Typemap threads/shared Hash/Util/FieldHash'
ksh=''
ld='cc'
lddlflags='-shared -O2 -L/usr/local/lib -fstack-protector'
diff --git a/djgpp/config.over b/djgpp/config.over
index f385f55369..5d97c85725 100644
--- a/djgpp/config.over
+++ b/djgpp/config.over
@@ -46,6 +46,7 @@ repair()
-e 's=cwd=Cwd=' \
-e 's=perlio/via=PerlIO/via=' \
-e 's=perlio/encoding=PerlIO/encoding=' \
+ -e 's=xs/apitest/keywordrpn=XS/APItest/KeywordRPN=' \
-e 's=xs/apitest=XS/APItest=' \
-e 's=xs/typemap=XS/Typemap=' \
-e 's=unicode/normaliz=Unicode/Normalize=' \
diff --git a/embed.fnc b/embed.fnc
index 3d072823b2..47dfa4223d 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2228,6 +2228,8 @@ ApoM |const char *|fetch_cop_label|NULLOK struct refcounted_he *const chain \
xpoM |struct refcounted_he *|store_cop_label \
|NULLOK struct refcounted_he *const chain|NN const char *label
+xpo |int |keyword_plugin_standard|NN char* keyword_ptr|STRLEN keyword_len|NN OP** op_ptr
+
END_EXTERN_C
/*
* ex: set ts=8 sts=4 sw=4 noet:
diff --git a/ext/XS-APItest-KeywordRPN/KeywordRPN.pm b/ext/XS-APItest-KeywordRPN/KeywordRPN.pm
new file mode 100644
index 0000000000..085d3f68b2
--- /dev/null
+++ b/ext/XS-APItest-KeywordRPN/KeywordRPN.pm
@@ -0,0 +1,146 @@
+=head1 NAME
+
+XS::APItest::KeywordRPN - write arithmetic expressions in RPN
+
+=head1 SYNOPSIS
+
+ use XS::APItest::KeywordRPN qw(rpn calcrpn);
+
+ $triangle = rpn($n $n 1 + * 2 /);
+
+ calcrpn $triangle { $n $n 1 + * 2 / }
+
+=head1 DESCRIPTION
+
+This module supplies plugged-in keywords, using the new mechanism in Perl
+5.11.2, that allow arithmetic to be expressed in reverse Polish notation,
+in an otherwise Perl program. This module has serious limitations and
+is not intended for real use: its purpose is only to test the keyword
+plugin mechanism. For that purpose it is part of the Perl core source
+distribution, and is not meant to be installed.
+
+=head2 RPN expression syntax
+
+Tokens of an RPN expression may be separated by whitespace, but such
+separation is usually not required. It is required only where unseparated
+tokens would look like a longer token. For example, C<12 34 +> can be
+written as C<12 34+>, but not as C<1234 +>.
+
+An RPN expression may be any of:
+
+=over
+
+=item C<1234>
+
+A sequence of digits is an unsigned decimal literal number.
+
+=item C<$foo>
+
+An alphanumeric name preceded by dollar sign refers to a Perl scalar
+variable. Only variables declared with C<my> or C<state> are supported.
+If the variable's value is not a native integer, it will be converted
+to an integer, by Perl's usual mechanisms, at the time it is evaluated.
+
+=item I<A> I<B> C<+>
+
+Sum of I<A> and I<B>.
+
+=item I<A> I<B> C<->
+
+Difference of I<A> and I<B>, the result of subtracting I<B> from I<A>.
+
+=item I<A> I<B> C<*>
+
+Product of I<A> and I<B>.
+
+=item I<A> I<B> C</>
+
+Quotient when I<A> is divided by I<B>, rounded towards zero.
+Division by zero generates an exception.
+
+=item I<A> I<B> C<%>
+
+Remainder when I<A> is divided by I<B> with the quotient rounded towards zero.
+Division by zero generates an exception.
+
+=back
+
+Because the arithmetic operators all have fixed arity and are postfixed,
+there is no need for operator precedence, nor for a grouping operator
+to override precedence. This is half of the point of RPN.
+
+An RPN expression can also be interpreted in another way, as a sequence
+of operations on a stack, one operation per token. A literal or variable
+token pushes a value onto the stack. A binary operator pulls two items
+off the stack, performs a calculation with them, and pushes the result
+back onto the stack. The stack starts out empty, and at the end of the
+expression there must be exactly one value left on the stack.
+
+=cut
+
+package XS::APItest::KeywordRPN;
+
+{ use 5.011001; }
+use warnings;
+use strict;
+
+our $VERSION = "0.000";
+
+require XSLoader;
+XSLoader::load(__PACKAGE__, $VERSION);
+
+=head1 OPERATORS
+
+These are the operators being added to the Perl language.
+
+=over
+
+=item rpn(EXPRESSION)
+
+This construct is a Perl expression. I<EXPRESSION> must be an RPN
+arithmetic expression, as described above. The RPN expression is
+evaluated, and its value is returned as the value of the Perl expression.
+
+=item calcrpn VARIABLE { EXPRESSION }
+
+This construct is a complete Perl statement. (No semicolon should
+follow the closing brace.) I<VARIABLE> must be a Perl scalar C<my>
+variable, and I<EXPRESSION> must be an RPN arithmetic expression as
+described above. The RPN expression is evaluated, and its value is
+assigned to the variable.
+
+=back
+
+=head1 BUGS
+
+This module only performs arithmetic on native integers, and only a
+small subset of the arithmetic operations that Perl offers. This is
+due to it being intended only for demonstration and test purposes.
+
+The RPN parser is liable to leak memory when a parse error occurs.
+It doesn't leak on success, however.
+
+The linkage with Perl's lexer is liable to fail when an RPN expression
+is spread across multiple lines.
+
+=head1 SEE ALSO
+
+L<Devel::Declare>,
+L<perlapi/PL_keyword_plugin>
+
+=head1 AUTHOR
+
+Andrew Main (Zefram) <zefram@fysh.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2009 Andrew Main (Zefram) <zefram@fysh.org>
+
+=head1 LICENSE
+
+This module is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/ext/XS-APItest-KeywordRPN/KeywordRPN.xs b/ext/XS-APItest-KeywordRPN/KeywordRPN.xs
new file mode 100644
index 0000000000..219d6ac1d9
--- /dev/null
+++ b/ext/XS-APItest-KeywordRPN/KeywordRPN.xs
@@ -0,0 +1,283 @@
+#define PERL_CORE 1 /* for pad_findmy() */
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
+#define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
+#define sv_is_string(sv) \
+ (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
+ (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
+
+static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv;
+static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
+
+/* low-level parser helpers */
+
+#define PL_bufptr (PL_parser->bufptr)
+#define PL_bufend (PL_parser->bufend)
+
+static char THX_peek_char(pTHX)
+{
+ if(PL_bufptr == PL_bufend)
+ Perl_croak(aTHX_
+ "unexpected EOF "
+ "(or you were unlucky about buffer position, FIXME)");
+ return *PL_bufptr;
+}
+#define peek_char() THX_peek_char(aTHX)
+
+static char THX_read_char(pTHX)
+{
+ char c = peek_char();
+ PL_bufptr++;
+ if(c == '\n') CopLINE_inc(PL_curcop);
+ return c;
+}
+#define read_char() THX_read_char(aTHX)
+
+static void THX_skip_opt_ws(pTHX)
+{
+ while(1) {
+ switch(peek_char()) {
+ case '\t': case '\n': case '\v': case '\f': case ' ':
+ read_char();
+ break;
+ default:
+ return;
+ }
+ }
+}
+#define skip_opt_ws() THX_skip_opt_ws(aTHX)
+
+/* RPN parser */
+
+static OP *THX_parse_var(pTHX)
+{
+ SV *varname = sv_2mortal(newSVpvs("$"));
+ PADOFFSET varpos;
+ OP *padop;
+ if(peek_char() != '$') Perl_croak(aTHX_ "RPN syntax error");
+ read_char();
+ while(1) {
+ char c = peek_char();
+ if(!isALNUM(c)) break;
+ read_char();
+ sv_catpvn_nomg(varname, &c, 1);
+ }
+ if(SvCUR(varname) < 2) Perl_croak(aTHX_ "RPN syntax error");
+ varpos = pad_findmy(SvPVX(varname));
+ if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
+ Perl_croak(aTHX_ "RPN only supports \"my\" variables");
+ padop = newOP(OP_PADSV, 0);
+ padop->op_targ = varpos;
+ return padop;
+}
+#define parse_var() THX_parse_var(aTHX)
+
+#define push_rpn_item(o) \
+ (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop)
+#define pop_rpn_item() \
+ (!stack ? (Perl_croak(aTHX_ "RPN stack underflow"), (OP*)NULL) : \
+ (tmpop = stack, stack = stack->op_sibling, \
+ tmpop->op_sibling = NULL, tmpop))
+
+static OP *THX_parse_rpn_expr(pTHX)
+{
+ OP *stack = NULL, *tmpop;
+ while(1) {
+ char c;
+ skip_opt_ws();
+ c = peek_char();
+ switch(c) {
+ case /*(*/')': case /*{*/'}': {
+ OP *result = pop_rpn_item();
+ if(stack)
+ Perl_croak(aTHX_
+ "RPN expression must return "
+ "a single value");
+ return result;
+ } break;
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9': {
+ UV val = 0;
+ do {
+ read_char();
+ val = 10*val + (c - '0');
+ c = peek_char();
+ } while(c >= '0' && c <= '9');
+ push_rpn_item(newSVOP(OP_CONST, 0,
+ newSVuv(val)));
+ } break;
+ case '$': {
+ push_rpn_item(parse_var());
+ } break;
+ case '+': {
+ OP *b = pop_rpn_item();
+ OP *a = pop_rpn_item();
+ read_char();
+ push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
+ } break;
+ case '-': {
+ OP *b = pop_rpn_item();
+ OP *a = pop_rpn_item();
+ read_char();
+ push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
+ } break;
+ case '*': {
+ OP *b = pop_rpn_item();
+ OP *a = pop_rpn_item();
+ read_char();
+ push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
+ } break;
+ case '/': {
+ OP *b = pop_rpn_item();
+ OP *a = pop_rpn_item();
+ read_char();
+ push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
+ } break;
+ case '%': {
+ OP *b = pop_rpn_item();
+ OP *a = pop_rpn_item();
+ read_char();
+ push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
+ } break;
+ default: {
+ Perl_croak(aTHX_ "RPN syntax error");
+ } break;
+ }
+ }
+}
+#define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
+
+static OP *THX_parse_keyword_rpn(pTHX)
+{
+ OP *op;
+ skip_opt_ws();
+ if(peek_char() != '('/*)*/)
+ Perl_croak(aTHX_ "RPN expression must be parenthesised");
+ read_char();
+ op = parse_rpn_expr();
+ if(peek_char() != /*(*/')')
+ Perl_croak(aTHX_ "RPN expression must be parenthesised");
+ read_char();
+ return op;
+}
+#define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
+
+static OP *THX_parse_keyword_calcrpn(pTHX)
+{
+ OP *varop, *exprop;
+ skip_opt_ws();
+ varop = parse_var();
+ skip_opt_ws();
+ if(peek_char() != '{'/*}*/)
+ Perl_croak(aTHX_ "RPN expression must be braced");
+ read_char();
+ exprop = parse_rpn_expr();
+ if(peek_char() != /*{*/'}')
+ Perl_croak(aTHX_ "RPN expression must be braced");
+ read_char();
+ return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
+}
+#define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
+
+/* plugin glue */
+
+static int THX_keyword_active(pTHX_ SV *hintkey_sv)
+{
+ HE *he;
+ if(!GvHV(PL_hintgv)) return 0;
+ he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
+ SvSHARED_HASH(hintkey_sv));
+ return he && SvTRUE(HeVAL(he));
+}
+#define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
+
+static void THX_keyword_enable(pTHX_ SV *hintkey_sv)
+{
+ SV *val_sv = newSViv(1);
+ HE *he;
+ PL_hints |= HINT_LOCALIZE_HH;
+ gv_HVadd(PL_hintgv);
+ he = hv_store_ent(GvHV(PL_hintgv),
+ hintkey_sv, val_sv, SvSHARED_HASH(hintkey_sv));
+ if(he) {
+ SV *val = HeVAL(he);
+ SvSETMAGIC(val);
+ } else {
+ SvREFCNT_dec(val_sv);
+ }
+}
+#define keyword_enable(hintkey_sv) THX_keyword_enable(aTHX_ hintkey_sv)
+
+static void THX_keyword_disable(pTHX_ SV *hintkey_sv)
+{
+ if(GvHV(PL_hintgv)) {
+ PL_hints |= HINT_LOCALIZE_HH;
+ hv_delete_ent(GvHV(PL_hintgv),
+ hintkey_sv, G_DISCARD, SvSHARED_HASH(hintkey_sv));
+ }
+}
+#define keyword_disable(hintkey_sv) THX_keyword_disable(aTHX_ hintkey_sv)
+
+static int my_keyword_plugin(pTHX_
+ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
+{
+ if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) &&
+ keyword_active(hintkey_rpn_sv)) {
+ *op_ptr = parse_keyword_rpn();
+ return KEYWORD_PLUGIN_EXPR;
+ } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) &&
+ keyword_active(hintkey_calcrpn_sv)) {
+ *op_ptr = parse_keyword_calcrpn();
+ return KEYWORD_PLUGIN_STMT;
+ } else {
+ return next_keyword_plugin(aTHX_
+ keyword_ptr, keyword_len, op_ptr);
+ }
+}
+
+MODULE = XS::APItest::KeywordRPN PACKAGE = XS::APItest::KeywordRPN
+
+BOOT:
+ hintkey_rpn_sv = newSVpvs_share("XS::APItest::KeywordRPN/rpn");
+ hintkey_calcrpn_sv = newSVpvs_share("XS::APItest::KeywordRPN/calcrpn");
+ next_keyword_plugin = PL_keyword_plugin;
+ PL_keyword_plugin = my_keyword_plugin;
+
+void
+import(SV *class, ...)
+PREINIT:
+ int i;
+PPCODE:
+ for(i = 1; i != items; i++) {
+ SV *item = ST(i);
+ if(sv_is_string(item) && strEQ(SvPVX(item), "rpn")) {
+ keyword_enable(hintkey_rpn_sv);
+ } else if(sv_is_string(item) && strEQ(SvPVX(item), "calcrpn")) {
+ keyword_enable(hintkey_calcrpn_sv);
+ } else {
+ Perl_croak(aTHX_
+ "\"%s\" is not exported by the %s module",
+ SvPV_nolen(item), SvPV_nolen(ST(0)));
+ }
+ }
+
+void
+unimport(SV *class, ...)
+PREINIT:
+ int i;
+PPCODE:
+ for(i = 1; i != items; i++) {
+ SV *item = ST(i);
+ if(sv_is_string(item) && strEQ(SvPVX(item), "rpn")) {
+ keyword_disable(hintkey_rpn_sv);
+ } else if(sv_is_string(item) && strEQ(SvPVX(item), "calcrpn")) {
+ keyword_disable(hintkey_calcrpn_sv);
+ } else {
+ Perl_croak(aTHX_
+ "\"%s\" is not exported by the %s module",
+ SvPV_nolen(item), SvPV_nolen(ST(0)));
+ }
+ }
diff --git a/ext/XS-APItest-KeywordRPN/Makefile.PL b/ext/XS-APItest-KeywordRPN/Makefile.PL
new file mode 100644
index 0000000000..ae2c72a40c
--- /dev/null
+++ b/ext/XS-APItest-KeywordRPN/Makefile.PL
@@ -0,0 +1,17 @@
+{ use 5.006; }
+use warnings;
+use strict;
+
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => "XS::APItest::KeywordRPN",
+ VERSION_FROM => "KeywordRPN.pm",
+ PREREQ_PM => {},
+ ABSTRACT_FROM => "KeywordRPN.pm",
+ AUTHOR => "Andrew Main (Zefram) <zefram\@fysh.org>",
+);
+
+sub MY::install { "install ::\n" }
+
+1;
diff --git a/ext/XS-APItest-KeywordRPN/README b/ext/XS-APItest-KeywordRPN/README
new file mode 100644
index 0000000000..4caa629af1
--- /dev/null
+++ b/ext/XS-APItest-KeywordRPN/README
@@ -0,0 +1,25 @@
+NAME
+
+XS::APItest::KeywordRPN - write arithmetic expressions in RPN
+
+DESCRIPTION
+
+This module supplies plugged-in keywords, using the new mechanism in Perl
+5.11.2, that allow arithmetic to be expressed in reverse Polish notation,
+in an otherwise Perl program. This module has serious limitations and
+is not intended for real use: its purpose is only to test the keyword
+plugin mechanism. For that purpose it is part of the Perl core source
+distribution, and is not meant to be installed.
+
+AUTHOR
+
+Andrew Main (Zefram) <zefram@fysh.org>
+
+COPYRIGHT
+
+Copyright (C) 2009 Andrew Main (Zefram) <zefram@fysh.org>
+
+LICENSE
+
+This module is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
diff --git a/ext/XS-APItest-KeywordRPN/t/keyword_plugin.t b/ext/XS-APItest-KeywordRPN/t/keyword_plugin.t
new file mode 100644
index 0000000000..2b705d733a
--- /dev/null
+++ b/ext/XS-APItest-KeywordRPN/t/keyword_plugin.t
@@ -0,0 +1,76 @@
+use warnings;
+use strict;
+
+use Test::More tests => 13;
+
+BEGIN { $^H |= 0x20000; }
+no warnings;
+
+my($t, $n);
+$n = 5;
+
+$t = undef;
+eval q{
+ use XS::APItest::KeywordRPN ();
+ $t = rpn($n $n 1 + * 2 /);
+};
+isnt $@, "";
+
+$t = undef;
+eval q{
+ use XS::APItest::KeywordRPN qw(rpn);
+ $t = rpn($n $n 1 + * 2 /);
+};
+is $@, "";
+is $t, 15;
+
+$t = undef;
+eval q{
+ use XS::APItest::KeywordRPN qw(rpn);
+ $t = join(":", "x", rpn($n $n 1 + * 2 /), "y");
+};
+is $@, "";
+is $t, "x:15:y";
+
+$t = undef;
+eval q{
+ use XS::APItest::KeywordRPN qw(rpn);
+ $t = 1 + rpn($n $n 1 + * 2 /) * 10;
+};
+is $@, "";
+is $t, 151;
+
+$t = undef;
+eval q{
+ use XS::APItest::KeywordRPN qw(rpn);
+ $t = rpn($n $n 1 + * 2 /);
+ $t++;
+};
+is $@, "";
+is $t, 16;
+
+$t = undef;
+eval q{
+ use XS::APItest::KeywordRPN qw(rpn);
+ $t = rpn($n $n 1 + * 2 /)
+ $t++;
+};
+isnt $@, "";
+
+$t = undef;
+eval q{
+ use XS::APItest::KeywordRPN qw(calcrpn);
+ calcrpn $t { $n $n 1 + * 2 / }
+ $t++;
+};
+is $@, "";
+is $t, 16;
+
+$t = undef;
+eval q{
+ use XS::APItest::KeywordRPN qw(calcrpn);
+ 123 + calcrpn $t { $n $n 1 + * 2 / } ;
+};
+isnt $@, "";
+
+1;
diff --git a/perl.h b/perl.h
index 9f80c5b4c3..45371d6339 100644
--- a/perl.h
+++ b/perl.h
@@ -4753,6 +4753,11 @@ typedef void (*XSUBADDR_t) (pTHX_ CV *);
typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
typedef void(CPERLscope(*Perl_ophook_t))(pTHX_ OP*);
+typedef int (CPERLscope(*Perl_keyword_plugin_t))(pTHX_ char*, STRLEN, OP**);
+
+#define KEYWORD_PLUGIN_DECLINE 0
+#define KEYWORD_PLUGIN_STMT 1
+#define KEYWORD_PLUGIN_EXPR 2
/* Interpreter exitlist entry */
typedef struct exitlistentry {
diff --git a/perlvars.h b/perlvars.h
index 49f4d5e31d..3639bd6ac0 100644
--- a/perlvars.h
+++ b/perlvars.h
@@ -8,9 +8,9 @@
*
*/
-/****************/
-/* Truly global */
-/****************/
+/*
+=head1 Global Variables
+*/
/* Don't forget to re-run embed.pl to propagate changes! */
@@ -186,3 +186,65 @@ PERLVARI(Gglobal_struct_size, U16, sizeof(struct perl_vars))
PERLVARI(Ginterp_size_5_10_0, U16,
PERL_INTERPRETER_SIZE_UPTO_MEMBER(PERL_LAST_5_10_0_INTERP_MEMBER))
#endif
+
+/*
+=for apidoc AmUx|Perl_keyword_plugin_t|PL_keyword_plugin
+
+Function pointer, pointing at a function used to handle extended keywords.
+The function should be declared as
+
+ int keyword_plugin_function(pTHX_
+ char *keyword_ptr, STRLEN keyword_len,
+ OP **op_ptr)
+
+The function is called from the tokeniser, whenever a possible keyword
+is seen. C<keyword_ptr> points at the word in the parser's input
+buffer, and C<keyword_len> gives its length; it is not null-terminated.
+The function is expected to examine the word, and possibly other state
+such as L<%^H|perlvar/%^H>, to decide whether it wants to handle it
+as an extended keyword. If it does not, the function should return
+C<KEYWORD_PLUGIN_DECLINE>, and the normal parser process will continue.
+
+If the function wants to handle the keyword, it first must
+parse anything following the keyword that is part of the syntax
+introduced by the keyword. The lexer interface is poorly documented.
+Broadly speaking, parsing needs to look at the buffer that extends
+from C<PL_parser-E<gt>bufptr> to C<PL_parser-E<gt>bufend>, and
+C<PL_parser-E<gt>bufptr> must be advanced across whatever text is
+consumed by the parsing process. The buffer end is not necessarily the
+real end of the input text, but refilling the buffer is too complicated
+to discuss here. See L<Devel::Declare> for some parsing experience,
+and hope for more core support in a future version of Perl.
+
+When a keyword is being handled, the plugin function must build
+a tree of C<OP> structures, representing the code that was parsed.
+The root of the tree must be stored in C<*op_ptr>. The function then
+returns a contant indicating the syntactic role of the construct that
+it has parsed: C<KEYWORD_PLUGIN_STMT> if it is a complete statement, or
+C<KEYWORD_PLUGIN_EXPR> if it is an expression. Note that a statement
+construct cannot be used inside an expression (except via C<do BLOCK>
+and similar), and an expression is not a complete statement (it requires
+at least a terminating semicolon).
+
+When a keyword is handled, the plugin function may also have
+(compile-time) side effects. It may modify C<%^H>, define functions, and
+so on. Typically, if side effects are the main purpose of a handler,
+it does not wish to generate any ops to be included in the normal
+compilation. In this case it is still required to supply an op tree,
+but it suffices to generate a single null op.
+
+That's how the C<*PL_keyword_plugin> function needs to behave overall.
+Conventionally, however, one does not completely replace the existing
+handler function. Instead, take a copy of C<PL_keyword_plugin> before
+assigning your own function pointer to it. Your handler function should
+look for keywords that it is interested in and handle those. Where it
+is not interested, it should call the saved plugin function, passing on
+the arguments it received. Thus C<PL_keyword_plugin> actually points
+at a chain of handler functions, all of which have an opportunity to
+handle keywords, and only the last function in the chain (built into
+the Perl core) will normally return C<KEYWORD_PLUGIN_DECLINE>.
+
+=cut
+*/
+
+PERLVARI(Gkeyword_plugin, Perl_keyword_plugin_t, MEMBER_TO_FPTR(Perl_keyword_plugin_standard))
diff --git a/perly.y b/perly.y
index 5ec5845de2..544c2e9edb 100644
--- a/perly.y
+++ b/perly.y
@@ -73,6 +73,7 @@
%token <opval> WORD METHOD FUNCMETH THING PMFUNC PRIVATEREF
%token <opval> FUNC0SUB UNIOPSUB LSTOPSUB
+%token <opval> PLUGEXPR PLUGSTMT
%token <p_tkval> LABEL
%token <i_tkval> FORMAT SUB ANONSUB PACKAGE USE
%token <i_tkval> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR
@@ -241,6 +242,8 @@ line : label cond
}
})
}
+ | label PLUGSTMT
+ { $$ = newSTATEOP(0, PVAL($1), $2); }
;
/* An expression which may have a side-effect */
@@ -1244,6 +1247,7 @@ term : termbinop
newSVOP(OP_CONST, 0, newSVpvs("Unimplemented")));
TOKEN_GETMAD($1,$$,'X');
}
+ | PLUGEXPR
;
/* "my" declarations, with optional attributes */
diff --git a/plan9/config_sh.sample b/plan9/config_sh.sample
index c11635953a..763f7aaf75 100644
--- a/plan9/config_sh.sample
+++ b/plan9/config_sh.sample
@@ -733,7 +733,7 @@ issymlink='/bin/test -h'
ivdformat='"ld"'
ivsize='4'
ivtype='long'
-known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attributes re threads threads/shared'
+known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Time/HiRes Unicode/Normalize XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes re threads threads/shared'
ksh=''
ld='ld'
lddlflags=''
diff --git a/pod/perl5112delta.pod b/pod/perl5112delta.pod
index 4d524670b3..ca8c8096ff 100644
--- a/pod/perl5112delta.pod
+++ b/pod/perl5112delta.pod
@@ -52,6 +52,28 @@ boolean, string or number of objects. It is invoked when an object
appears on the right hand side of the C<=~> operator, or when it is
interpolated into a regexp. See L<overload>.
+=head2 Pluggable keywords
+
+Extension modules can now cleanly hook into the Perl parser to define new
+kinds of keyword-headed expression and compound statement. The syntax
+following the keyword is defined entirely by the extension. This allow
+a completely non-Perl sublanguage to be parsed inline, with the right
+ops cleanly generated.
+
+This feature is currently considered experimental, and using it to do
+anything interesting is difficult. Many necessary supporting facilities,
+such as the lexer and the pad system, can only be accessed through
+unsupported internal interfaces. It is intended that the Perl 5.13
+development cycle will see the addition of clean, supported interfaces
+for many of these functions. In Perl 5.12 most uses of pluggable keywords
+will be via L<Devel::Declare>.
+
+See L<perlapi/PL_keyword_plugin> for the mechanism. The Perl core source
+distribution also includes a new module L<XS::APItest::KeywordRPN>, which
+implements reverse Polish notation arithmetic via pluggable keywords.
+This module is mainly used for test purposes, and is not normally
+installed, but also serves as an example of how to use the new mechanism.
+
=head1 New Platforms
XXX List any platforms that this version of perl compiles on, that previous
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 3f0a78a3fe..db9a17c2fb 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -373,6 +373,11 @@ is not the same as
$var = 'myvar';
$sym = "mypack::$var";
+=item Bad plugin affecting keyword '%s'
+
+(F) An extension using the keyword plugin mechanism violated the
+plugin API.
+
=item Bad realloc() ignored
(S malloc) An internal routine called realloc() on something that had
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index c440faa410..862e0ba73d 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -86,6 +86,14 @@ which return C<-1> on failure. Exceptions to this rule are C<wait>,
C<waitpid>, and C<syscall>. System calls also set the special C<$!>
variable on failure. Other functions do not, except accidentally.
+Extension modules can also hook into the Perl parser to define new
+kinds of keyword-headed expression. These may look like functions, but
+may also look completely different. The syntax following the keyword
+is defined entirely by the extension. If you are an implementor, see
+L<perlapi/PL_keyword_plugin> for the mechanism. If you are using such
+a module, see the module's documentation for details of the syntax that
+it defines.
+
=head2 Perl Functions by Category
X<function>
diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod
index 5e80901b09..d5fc4a72c1 100644
--- a/pod/perlsyn.pod
+++ b/pod/perlsyn.pod
@@ -272,6 +272,14 @@ conditional is about to be evaluated again. Thus it can be used to
increment a loop variable, even when the loop has been continued via
the C<next> statement.
+Extension modules can also hook into the Perl parser to define new
+kinds of compound statement. These are introduced by a keyword which
+the extension recognises, and the syntax following the keyword is
+defined entirely by the extension. If you are an implementor, see
+L<perlapi/PL_keyword_plugin> for the mechanism. If you are using such
+a module, see the module's documentation for details of the syntax that
+it defines.
+
=head2 Loop Control
X<loop control> X<loop, control> X<next> X<last> X<redo> X<continue>
diff --git a/symbian/install.cfg b/symbian/install.cfg
index 4b86b8211e..879b3619e7 100644
--- a/symbian/install.cfg
+++ b/symbian/install.cfg
@@ -114,5 +114,6 @@ ext XSLoader
# ext Unicode/Normalize nonconst
# ext Win32 USELESS
# ext XS/APItest USELESS
+# ext XS/APItest/KeywordRPN USELESS
# ext XS/Typemap nonconst USELESS
diff --git a/toke.c b/toke.c
index fa78415331..deb3b11863 100644
--- a/toke.c
+++ b/toke.c
@@ -343,6 +343,8 @@ static struct debug_tokens {
{ OROP, TOKENTYPE_IVAL, "OROP" },
{ OROR, TOKENTYPE_NONE, "OROR" },
{ PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
+ { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
+ { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
{ PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
{ POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
{ POSTINC, TOKENTYPE_NONE, "POSTINC" },
@@ -5220,6 +5222,7 @@ Perl_yylex(pTHX)
case 'z': case 'Z':
keylookup: {
+ bool anydelim;
I32 tmp;
orig_keyword = 0;
@@ -5230,34 +5233,19 @@ Perl_yylex(pTHX)
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
/* Some keywords can be followed by any delimiter, including ':' */
- tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
+ anydelim = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
(len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
(PL_tokenbuf[0] == 'q' &&
strchr("qwxr", PL_tokenbuf[1])))));
/* x::* is just a word, unless x is "CORE" */
- if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
+ if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
goto just_a_word;
d = s;
while (d < PL_bufend && isSPACE(*d))
d++; /* no comments skipped here, or s### is misparsed */
- /* Is this a label? */
- if (!tmp && PL_expect == XSTATE
- && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
- tmp = keyword(PL_tokenbuf, len, 0);
- if (tmp)
- Perl_croak(aTHX_ "Can't use keyword '%s' as a label", PL_tokenbuf);
- s = d + 1;
- pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
- CLINE;
- TOKEN(LABEL);
- }
- else
- /* Check for keywords */
- tmp = keyword(PL_tokenbuf, len, 0);
-
/* Is this a word before a => operator? */
if (*d == '=' && d[1] == '>') {
CLINE;
@@ -5268,6 +5256,47 @@ Perl_yylex(pTHX)
TERM(WORD);
}
+ /* Check for plugged-in keyword */
+ {
+ OP *o;
+ int result;
+ char *saved_bufptr = PL_bufptr;
+ PL_bufptr = s;
+ result = CALL_FPTR(PL_keyword_plugin)(aTHX_ PL_tokenbuf, len, &o);
+ s = PL_bufptr;
+ if (result == KEYWORD_PLUGIN_DECLINE) {
+ /* not a plugged-in keyword */
+ PL_bufptr = saved_bufptr;
+ } else if (result == KEYWORD_PLUGIN_STMT) {
+ pl_yylval.opval = o;
+ CLINE;
+ PL_expect = XSTATE;
+ return REPORT(PLUGSTMT);
+ } else if (result == KEYWORD_PLUGIN_EXPR) {
+ pl_yylval.opval = o;
+ CLINE;
+ PL_expect = XOPERATOR;
+ return REPORT(PLUGEXPR);
+ } else {
+ Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
+ PL_tokenbuf);
+ }
+ }
+
+ /* Check for built-in keyword */
+ tmp = keyword(PL_tokenbuf, len, 0);
+
+ /* Is this a label? */
+ if (!anydelim && PL_expect == XSTATE
+ && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
+ if (tmp)
+ Perl_croak(aTHX_ "Can't use keyword '%s' as a label", PL_tokenbuf);
+ s = d + 1;
+ pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
+ CLINE;
+ TOKEN(LABEL);
+ }
+
if (tmp < 0) { /* second-class keyword? */
GV *ogv = NULL; /* override (winner) */
GV *hgv = NULL; /* hidden (loser) */
@@ -13015,6 +13044,18 @@ Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
return (char *)s;
}
+int
+Perl_keyword_plugin_standard(pTHX_
+ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
+{
+ PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
+ PERL_UNUSED_CONTEXT;
+ PERL_UNUSED_ARG(keyword_ptr);
+ PERL_UNUSED_ARG(keyword_len);
+ PERL_UNUSED_ARG(op_ptr);
+ return KEYWORD_PLUGIN_DECLINE;
+}
+
/*
* Local variables:
* c-indentation-style: bsd
diff --git a/utils/perlivp.PL b/utils/perlivp.PL
index 762b4b3872..59865741e1 100644
--- a/utils/perlivp.PL
+++ b/utils/perlivp.PL
@@ -213,6 +213,7 @@ if (defined($Config{'extensions'})) {
next if $_ eq 'Devel/DProf';
# test modules
next if $_ eq 'XS/APItest';
+ next if $_ eq 'XS/APItest/KeywordRPN';
next if $_ eq 'XS/Typemap';
# VMS$ perl -e "eval ""require \""Devel/DProf.pm\"";"" print $@"
# \NT> perl -e "eval \"require 'Devel/DProf.pm'\"; print $@"