ext/XS-APItest-KeywordRPN/t/keyword_plugin.t test keyword plugin mechanism
ext/XS-APItest-KeywordRPN/t/multiline.t test plugin parsing across lines
ext/XS-APItest-KeywordRPN/t/stuff_svcur_bug.t test for a bug in lex_stuff_pvn
+ext/XS-APItest-KeywordRPN/t/swaptwostmts.t test recursive descent statement parsing
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
AMpd |I32 |lex_peek_unichar|U32 flags
AMpd |I32 |lex_read_unichar|U32 flags
AMpd |void |lex_read_space |U32 flags
+: Public parser API
+AMpd |OP* |parse_fullstmt |U32 flags
: Used in various files
Ap |void |op_null |NN OP* o
: FIXME. Used by Data::Alias
p |int |yyerror |NN const char *const s
: Used in perly.y, and by Data::Alias
EXp |int |yylex
+p |void |yyunlex
: Used in perl.c, pp_ctl.c
-p |int |yyparse
+p |int |yyparse |int gramtype
: Only used in scope.c
p |void |parser_free |NN const yy_parser *parser
#if defined(PERL_IN_TOKE_C)
s |void |curmad |char slot|NULLOK SV *sv
# endif
Mp |int |madlex
-Mp |int |madparse
+Mp |int |madparse |int gramtype
#endif
#if !defined(HAS_SIGNBIT)
AMdnoP |int |Perl_signbit |NV f
(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv;
+static SV *hintkey_swaptwostmts_sv;
static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
/* low-level parser helpers */
}
#define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
+static OP *THX_parse_keyword_swaptwostmts(pTHX)
+{
+ OP *a, *b;
+ a = parse_fullstmt(0);
+ b = parse_fullstmt(0);
+ if(a && b)
+ PL_hints |= HINT_BLOCK_SCOPE;
+ /* should use append_list(), but that's not part of the public API */
+ return !a ? b : !b ? a : newLISTOP(OP_LINESEQ, 0, b, a);
+}
+#define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX)
+
/* plugin glue */
static int THX_keyword_active(pTHX_ SV *hintkey_sv)
keyword_active(hintkey_stufftest_sv)) {
*op_ptr = parse_keyword_stufftest();
return KEYWORD_PLUGIN_STMT;
+ } else if(keyword_len == 12 &&
+ strnEQ(keyword_ptr, "swaptwostmts", 12) &&
+ keyword_active(hintkey_swaptwostmts_sv)) {
+ *op_ptr = parse_keyword_swaptwostmts();
+ return KEYWORD_PLUGIN_STMT;
} else {
return next_keyword_plugin(aTHX_
keyword_ptr, keyword_len, op_ptr);
hintkey_calcrpn_sv = newSVpvs_share("XS::APItest::KeywordRPN/calcrpn");
hintkey_stufftest_sv =
newSVpvs_share("XS::APItest::KeywordRPN/stufftest");
+ hintkey_swaptwostmts_sv =
+ newSVpvs_share("XS::APItest::KeywordRPN/swaptwostmts");
next_keyword_plugin = PL_keyword_plugin;
PL_keyword_plugin = my_keyword_plugin;
} else if(sv_is_string(item) &&
strEQ(SvPVX(item), "stufftest")) {
keyword_enable(hintkey_stufftest_sv);
+ } else if(sv_is_string(item) &&
+ strEQ(SvPVX(item), "swaptwostmts")) {
+ keyword_enable(hintkey_swaptwostmts_sv);
} else {
croak("\"%s\" is not exported by the %s module",
SvPV_nolen(item), SvPV_nolen(ST(0)));
} else if(sv_is_string(item) &&
strEQ(SvPVX(item), "stufftest")) {
keyword_disable(hintkey_stufftest_sv);
+ } else if(sv_is_string(item) &&
+ strEQ(SvPVX(item), "swaptwostmts")) {
+ keyword_disable(hintkey_swaptwostmts_sv);
} else {
croak("\"%s\" is not exported by the %s module",
SvPV_nolen(item), SvPV_nolen(ST(0)));
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More tests => 22;
+
+BEGIN { $^H |= 0x20000; }
+
+my $t;
+
+$t = "";
+eval q{
+ use XS::APItest::KeywordRPN ();
+ $t .= "a";
+ swaptwostmts
+ $t .= "b";
+ $t .= "c";
+ $t .= "d";
+};
+isnt $@, "";
+
+$t = "";
+eval q{
+ use XS::APItest::KeywordRPN qw(swaptwostmts);
+ $t .= "a";
+ swaptwostmts
+ $t .= "b";
+ $t .= "c";
+ $t .= "d";
+};
+is $@, "";
+is $t, "acbd";
+
+$t = "";
+eval q{
+ use XS::APItest::KeywordRPN qw(swaptwostmts);
+ $t .= "a";
+ swaptwostmts
+ if(1) { $t .= "b"; }
+ $t .= "c";
+ $t .= "d";
+};
+is $@, "";
+is $t, "acbd";
+
+$t = "";
+eval q{
+ use XS::APItest::KeywordRPN qw(swaptwostmts);
+ $t .= "a";
+ swaptwostmts
+ $t .= "b";
+ if(1) { $t .= "c"; }
+ $t .= "d";
+};
+is $@, "";
+is $t, "acbd";
+
+$t = "";
+eval q{
+ use XS::APItest::KeywordRPN qw(swaptwostmts);
+ $t .= "a";
+ swaptwostmts
+ $t .= "b";
+ foreach(1..3) {
+ $t .= "c";
+ swaptwostmts
+ $t .= "d";
+ $t .= "e";
+ $t .= "f";
+ }
+ $t .= "g";
+};
+is $@, "";
+is $t, "acedfcedfcedfbg";
+
+$t = "";
+eval q{
+ use XS::APItest::KeywordRPN qw(swaptwostmts);
+ $t .= "a";
+ swaptwostmts
+ $t .= "b";
+ $t .= "c";
+};
+is $@, "";
+is $t, "acb";
+
+$t = "";
+eval q{
+ use XS::APItest::KeywordRPN qw(swaptwostmts);
+ $t .= "a";
+ swaptwostmts
+ $t .= "b";
+ $t .= "c"
+};
+is $@, "";
+is $t, "acb";
+
+$t = "";
+eval q{
+ use XS::APItest::KeywordRPN qw(swaptwostmts);
+ $t .= "a";
+ swaptwostmts
+ $t .= "b"
+};
+isnt $@, "";
+
+$t = "";
+eval q{
+ use XS::APItest::KeywordRPN qw(swaptwostmts);
+ $_ = $t;
+ $_ .= "a";
+ swaptwostmts
+ if(1) { $_ .= "b"; }
+ tr/a-z/A-Z/;
+ $_ .= "d";
+ $t = $_;
+};
+is $@, "";
+is $t, "Abd";
+
+$t = "";
+eval q{
+ use XS::APItest::KeywordRPN qw(swaptwostmts);
+ sub add_to_t { $t .= $_[0]; }
+ add_to_t "a";
+ swaptwostmts
+ if(1) { add_to_t "b"; }
+ add_to_t "c";
+ add_to_t "d";
+};
+is $@, "";
+is $t, "acbd";
+
+$t = "";
+eval q{
+ use XS::APItest::KeywordRPN qw(swaptwostmts);
+ { $t .= "a"; }
+ swaptwostmts
+ if(1) { { $t .= "b"; } }
+ { $t .= "c"; }
+ { $t .= "d"; }
+};
+is $@, "";
+is $t, "acbd";
+
+$t = "";
+eval q{
+ use XS::APItest::KeywordRPN qw(swaptwostmts);
+ no warnings "void";
+ "@{[ $t .= 'a' ]}";
+ swaptwostmts
+ if(1) { "@{[ $t .= 'b' ]}"; }
+ "@{[ $t .= 'c' ]}";
+ "@{[ $t .= 'd' ]}";
+};
+is $@, "";
+is $t, "acbd";
+
+1;
/* now parse the script */
SETERRNO(0,SS_NORMAL);
- if (yyparse() || PL_parser->error_count) {
+ if (yyparse(GRAMPROG) || PL_parser->error_count) {
if (PL_minus_c)
Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
else {
typedef short int yytype_int16;
typedef signed char yysigned_char;
+/* YYINITDEPTH -- initial size of the parser's stacks. */
+#define YYINITDEPTH 200
+
#ifdef DEBUGGING
# define YYDEBUG 1
#else
yy_stack_frame *ps = parser->ps;
int i = 0;
- if (!parser->stack || ps == parser->stack)
+ if (!parser->stack)
return;
YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n"));
SvREFCNT_dec(ps->compcv);
ps--;
}
+
+ Safefree(parser->stack);
}
int
#ifdef PERL_IN_MADLY_C
-Perl_madparse (pTHX)
+Perl_madparse (pTHX_ int gramtype)
#else
-Perl_yyparse (pTHX)
+Perl_yyparse (pTHX_ int gramtype)
#endif
{
dVAR;
#ifndef PERL_IN_MADLY_C
# ifdef PERL_MAD
if (PL_madskills)
- return madparse();
+ return madparse(gramtype);
# endif
#endif
YYDPRINTF ((Perl_debug_log, "Starting parse\n"));
parser = PL_parser;
- ps = parser->ps;
- ENTER; /* force parser stack cleanup before we return */
+ ENTER; /* force parser state cleanup/restoration before we return */
+ SAVEPPTR(parser->yylval.pval);
+ SAVEINT(parser->yychar);
+ SAVEINT(parser->yyerrstatus);
+ SAVEINT(parser->stack_size);
+ SAVEINT(parser->yylen);
+ SAVEVPTR(parser->stack);
+ SAVEVPTR(parser->ps);
+
+ /* initialise state for this parse */
+ parser->yychar = gramtype;
+ parser->yyerrstatus = 0;
+ parser->stack_size = YYINITDEPTH;
+ parser->yylen = 0;
+ Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
+ ps = parser->ps = parser->stack;
+ ps->state = 0;
SAVEDESTRUCTOR_X(S_clear_yystack, parser);
/*------------------------------------------------------------.
/* FIXME for MAD - is the new mintro on while and until important? */
-%start prog
+%start grammar
%union {
I32 ival; /* __DEFAULT__ (marker for regen_perly.pl;
#endif
}
+%token <ival> GRAMPROG GRAMFULLSTMT
+
%token <i_tkval> '{' '}' '[' ']' '-' '+' '$' '@' '%' '*' '&' ';'
%token <opval> WORD METHOD FUNCMETH THING PMFUNC PRIVATEREF
%token <i_tkval> LOCAL MY MYSUB REQUIRE
%token <i_tkval> COLONATTR
-%type <ival> prog progstart remember mremember
+%type <ival> grammar prog progstart remember mremember
%type <ival> startsub startanonsub startformsub
/* FIXME for MAD - are these two ival? */
%type <ival> mydefsv mintro
-%type <opval> decl format subrout mysubrout package use peg
-
+%type <opval> fullstmt decl format subrout mysubrout package use peg
%type <opval> block package_block mblock lineseq line loop cond else
%type <opval> expr term subscripted scalar ary hsh arylen star amper sideff
%type <opval> argexpr nexpr texpr iexpr mexpr mnexpr miexpr
%% /* RULES */
+/* Top-level choice of what kind of thing yyparse was called to parse */
+grammar : GRAMPROG prog
+ { $$ = $2; }
+ | GRAMFULLSTMT fullstmt
+ {
+ PL_eval_root = $2;
+ $$ = 0;
+ yyunlex();
+ parser->yychar = YYEOF;
+ }
+ ;
+
/* The whole program */
prog : progstart
/*CONTINUED*/ lineseq
}
;
-/* A "line" in the program */
+/* A statement, or "line", in the program */
+fullstmt: decl
+ { $$ = $1; }
+ | line
+ {
+ PL_pad_reset_pending = TRUE;
+ $$ = $1;
+ }
+ ;
+
+/* A non-declaration statement */
line : label cond
{ $$ = newSTATEOP(0, PVAL($1), $2);
TOKEN_GETMAD($1,((LISTOP*)$$)->op_first,'L'); }
(P) The lexer got into a bad state while processing a case modifier.
+=item Parsing code internal error (%s)
+
+(F) Parsing code supplied by an extension violated the parser's API in
+a detectable way.
+
=item Pattern subroutine nesting without pos change exceeded limit in regex; marked by <-- HERE in m/%s/
(F) You used a pattern that uses too many nested subpattern calls without
* 3: yyparse() died
*/
STATIC int
-S_try_yyparse(pTHX)
+S_try_yyparse(pTHX_ int gramtype)
{
int ret;
dJMPENV;
JMPENV_PUSH(ret);
switch (ret) {
case 0:
- ret = yyparse() ? 1 : 0;
+ ret = yyparse(gramtype) ? 1 : 0;
break;
case 3:
break;
/* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
* so honour CATCH_GET and trap it here if necessary */
- yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse();
+ yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
if (yystatus || PL_parser->error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
Newxz(parser, 1, yy_parser);
ptr_table_store(PL_ptr_table, proto, parser);
- parser->yyerrstatus = 0;
- parser->yychar = YYEMPTY; /* Cause a token to be read. */
-
/* XXX these not yet duped */
parser->old_parser = NULL;
parser->stack = NULL;
#define pl_yylval (PL_parser->yylval)
-/* YYINITDEPTH -- initial size of the parser's stacks. */
-#define YYINITDEPTH 200
-
/* XXX temporary backwards compatibility */
#define PL_lex_brackets (PL_parser->lex_brackets)
#define PL_lex_brackstack (PL_parser->lex_brackstack)
parser->old_parser = oparser = PL_parser;
PL_parser = parser;
- Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
- parser->ps = parser->stack;
- parser->stack_size = YYINITDEPTH;
-
- parser->stack->state = 0;
- parser->yyerrstatus = 0;
- parser->yychar = YYEMPTY; /* Cause a token to be read. */
+ parser->stack = NULL;
+ parser->ps = NULL;
+ parser->stack_size = 0;
/* on scope exit, free this parser and restore any outer one */
SAVEPARSER(parser);
PerlIO_close(parser->rsfp);
SvREFCNT_dec(parser->rsfp_filters);
- Safefree(parser->stack);
Safefree(parser->lex_brackstack);
Safefree(parser->lex_casestack);
PL_parser = parser->old_parser;
#endif
}
+void
+Perl_yyunlex(pTHX)
+{
+ if (PL_parser->yychar != YYEMPTY) {
+ start_force(-1);
+ NEXTVAL_NEXTTOKE = PL_parser->yylval;
+ force_next(PL_parser->yychar);
+ PL_parser->yychar = YYEMPTY;
+ }
+}
+
STATIC SV *
S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
{
PL_thismad = 0;
/* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
- if (PL_pending_ident)
+ if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
return S_pending_ident(aTHX);
/* previous token ate up our whitespace? */
SvREFCNT_dec(tmp);
} );
/* check if there's an identifier for us to look at */
- if (PL_pending_ident)
+ if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
return REPORT(S_pending_ident(aTHX));
/* no identifier pending identification */
}
/*
+=for apidoc Amx|OP *|parse_fullstmt|U32 flags
+
+Parse a single complete Perl statement. This may be a normal imperative
+statement, including optional label, or a declaration that has
+compile-time effect. It is up to the caller to ensure that the dynamic
+parser state (L</PL_parser> et al) is correctly set to reflect the source
+of the code to be parsed and the lexical context for the statement.
+
+The op tree representing the statement is returned. This may be a
+null pointer if the statement is null, for example if it was actually
+a subroutine definition (which has compile-time side effects). If not
+null, it will be the result of a L</newSTATEOP> call, normally including
+a C<nextstate> or equivalent op.
+
+If an error occurs in parsing or compilation, in most cases a valid op
+tree (most likely null) is returned anyway. The error is reflected in
+the parser state, normally resulting in a single exception at the top
+level of parsing which covers all the compilation errors that occurred.
+Some compilation errors, however, will throw an exception immediately.
+
+The I<flags> parameter is reserved for future use, and must always
+be zero.
+
+=cut
+*/
+
+OP *
+Perl_parse_fullstmt(pTHX_ U32 flags)
+{
+ OP *fullstmtop;
+ if (flags)
+ Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
+ ENTER;
+ SAVEVPTR(PL_eval_root);
+ PL_eval_root = NULL;
+ if(yyparse(GRAMFULLSTMT) && !PL_parser->error_count)
+ qerror(Perl_mess(aTHX_ "Parse error"));
+ fullstmtop = PL_eval_root;
+ LEAVE;
+ return fullstmtop;
+}
+
+/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4