summaryrefslogtreecommitdiff
path: root/gnu/usr.bin/perl/perly.y
diff options
context:
space:
mode:
authorAndrew Fresh <afresh1@cvs.openbsd.org>2024-05-14 19:39:02 +0000
committerAndrew Fresh <afresh1@cvs.openbsd.org>2024-05-14 19:39:02 +0000
commit45c703581717284c37fbb2abc2968de039f80a64 (patch)
tree4bc6b627547b709d1beaa366b98c92444fe5c5b8 /gnu/usr.bin/perl/perly.y
parent0aa19f5e10f3aa68dc15f265cb9e764af0950d32 (diff)
Fix merge issues, remove excess files - match perl-5.38.2 dist
ok gkoehler@ Commit and we'll fix fallout bluhm@ Right away, please deraadt@
Diffstat (limited to 'gnu/usr.bin/perl/perly.y')
-rw-r--r--gnu/usr.bin/perl/perly.y447
1 files changed, 327 insertions, 120 deletions
diff --git a/gnu/usr.bin/perl/perly.y b/gnu/usr.bin/perl/perly.y
index 55321fa41ee..c0c09092c5e 100644
--- a/gnu/usr.bin/perl/perly.y
+++ b/gnu/usr.bin/perl/perly.y
@@ -38,13 +38,14 @@
%union {
I32 ival; /* __DEFAULT__ (marker for regen_perly.pl;
must always be 1st union member) */
- char *pval;
+ void *pval;
OP *opval;
GV *gvval;
}
%token <ival> GRAMPROG GRAMEXPR GRAMBLOCK GRAMBARESTMT GRAMFULLSTMT GRAMSTMTSEQ GRAMSUBSIGNATURE
+/* Tokens emitted by toke.c for simple punctiation characters - &, {, }, etc... */
%token <ival> PERLY_AMPERSAND
%token <ival> PERLY_BRACE_OPEN
%token <ival> PERLY_BRACE_CLOSE
@@ -62,38 +63,55 @@
%token <ival> PERLY_SNAIL
%token <ival> PERLY_STAR
-%token <opval> BAREWORD METHOD FUNCMETH THING PMFUNC PRIVATEREF QWLIST
+/* Tokens emitted by toke.c on simple keywords */
+%token <ival> KW_FORMAT KW_PACKAGE KW_CLASS
+%token <ival> KW_LOCAL KW_MY KW_FIELD
+%token <ival> KW_IF KW_ELSE KW_ELSIF KW_UNLESS
+%token <ival> KW_FOR KW_UNTIL KW_WHILE KW_CONTINUE
+%token <ival> KW_GIVEN KW_WHEN KW_DEFAULT
+%token <ival> KW_TRY KW_CATCH KW_FINALLY KW_DEFER
+%token <ival> KW_REQUIRE KW_DO
+
+/* The 'use' and 'no' keywords both emit this */
+%token <ival> KW_USE_or_NO
+
+/* The 'sub' keyword is a bit special; four different tokens depending on
+ * named-vs-anon, and whether signatures are in effect */
+%token <ival> KW_SUB_named KW_SUB_named_sig KW_SUB_anon KW_SUB_anon_sig
+%token <ival> KW_METHOD_named KW_METHOD_anon
+
+/* Tokens emitted in other situations */
+%token <opval> BAREWORD METHCALL0 METHCALL THING PMFUNC PRIVATEREF QWLIST
%token <opval> FUNC0OP FUNC0SUB UNIOPSUB LSTOPSUB
%token <opval> PLUGEXPR PLUGSTMT
%token <opval> LABEL
-%token <ival> FORMAT SUB SIGSUB ANONSUB ANON_SIGSUB PACKAGE USE
-%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR
-%token <ival> GIVEN WHEN DEFAULT
-%token <ival> TRY CATCH FINALLY
%token <ival> LOOPEX DOTDOT YADAYADA
%token <ival> FUNC0 FUNC1 FUNC UNIOP LSTOP
-%token <ival> MULOP ADDOP
-%token <ival> DOLSHARP DO HASHBRACK NOAMP
-%token <ival> LOCAL MY REQUIRE
+%token <ival> POWOP MULOP ADDOP
+%token <ival> DOLSHARP HASHBRACK NOAMP
%token <ival> COLONATTR FORMLBRACK FORMRBRACK
%token <ival> SUBLEXSTART SUBLEXEND
-%token <ival> DEFER
+%token <ival> PHASER
%type <ival> grammar remember mremember
-%type <ival> startsub startanonsub startformsub
+%type <ival> startsub startanonsub startanonmethod startformsub
%type <ival> mintro
+%type <ival> sigsub_or_method_named
%type <opval> stmtseq fullstmt labfullstmt barestmt block mblock else finally
%type <opval> expr term subscripted scalar ary hsh arylen star amper sideff
%type <opval> condition
+%type <opval> catch_paren
%type <opval> empty
%type <opval> sliceme kvslice gelem
%type <opval> listexpr nexpr texpr iexpr mexpr mnexpr
-%type <opval> optlistexpr optexpr optrepl indirob listop method
+%type <opval> optlistexpr optexpr optrepl indirob listop methodname
%type <opval> formname subname proto cont my_scalar my_var
%type <opval> list_of_scalars my_list_of_scalars refgen_topic formblock
%type <opval> subattrlist myattrlist myattrterm myterm
+%type <pval> fieldvar /* pval is PADNAME */
+%type <opval> optfieldattrlist fielddecl
%type <opval> termbinop termunop anonymous termdo
%type <opval> termrelop relopchain termeqop eqopchain
%type <ival> sigslurpsigil
@@ -105,29 +123,32 @@
%nonassoc <ival> PREC_LOW
%nonassoc LOOPEX
-%left <ival> OROP
-%left <ival> ANDOP
+%nonassoc <pval> PLUGIN_LOW_OP
+%left <ival> OROP <pval> PLUGIN_LOGICAL_OR_LOW_OP
+%left <ival> ANDOP <pval> PLUGIN_LOGICAL_AND_LOW_OP
%right <ival> NOTOP
%nonassoc LSTOP LSTOPSUB
%left PERLY_COMMA
-%right <ival> ASSIGNOP
+%right <ival> ASSIGNOP <pval> PLUGIN_ASSIGN_OP
%right <ival> PERLY_QUESTION_MARK PERLY_COLON
%nonassoc DOTDOT
-%left <ival> OROR DORDOR
-%left <ival> ANDAND
+%left <ival> OROR DORDOR <pval> PLUGIN_LOGICAL_OR_OP
+%left <ival> ANDAND <pval> PLUGIN_LOGICAL_AND_OP
%left <ival> BITOROP
%left <ival> BITANDOP
%left <ival> CHEQOP NCEQOP
%left <ival> CHRELOP NCRELOP
+%nonassoc <pval> PLUGIN_REL_OP
%nonassoc UNIOP UNIOPSUB
-%nonassoc REQUIRE
+%nonassoc KW_REQUIRE
%left <ival> SHIFTOP
-%left ADDOP
-%left MULOP
+%left ADDOP <pval> PLUGIN_ADD_OP
+%left MULOP <pval> PLUGIN_MUL_OP
%left <ival> MATCHOP
%right <ival> PERLY_EXCLAMATION_MARK PERLY_TILDE UMINUS REFGEN
-%right <ival> POWOP
+%right POWOP <pval> PLUGIN_POW_OP
%nonassoc <ival> PREINC PREDEC POSTINC POSTDEC POSTJOIN
+%nonassoc <pval> PLUGIN_HIGH_OP
%left <ival> ARROW
%nonassoc <ival> PERLY_PAREN_CLOSE
%left <ival> PERLY_PAREN_OPEN
@@ -218,6 +239,14 @@ grammar : GRAMPROG
}
;
+/* Either a signatured 'sub' or 'method' keyword */
+sigsub_or_method_named
+ : KW_SUB_named_sig
+ { $$ = KW_SUB_named_sig; }
+ | KW_METHOD_named
+ { $$ = KW_METHOD_named; }
+ ;
+
/* An ordinary block */
block : PERLY_BRACE_OPEN remember stmtseq PERLY_BRACE_CLOSE
{ if (parser->copline > (line_t)$PERLY_BRACE_OPEN)
@@ -255,6 +284,18 @@ mremember: %empty /* start a partial lexical scope */
parser->parsed_sub = 0; }
;
+/* The parenthesized variable of a catch block */
+catch_paren: empty
+ /* not really valid grammar but we detect it in the
+ * action block to throw a nicer error message */
+ | PERLY_PAREN_OPEN
+ { parser->in_my = 1; }
+ scalar
+ { parser->in_my = 0; intro_my(); }
+ PERLY_PAREN_CLOSE
+ { $$ = $scalar; }
+ ;
+
/* A sequence of statements in the program */
stmtseq
: empty
@@ -305,7 +346,7 @@ labfullstmt: LABEL barestmt
/* A bare statement, lacking label and other aspects of state op */
barestmt: PLUGSTMT
{ $$ = $PLUGSTMT; }
- | FORMAT startformsub formname formblock
+ | KW_FORMAT startformsub formname formblock
{
CV *fmtcv = PL_compcv;
newFORM($startformsub, $formname, $formblock);
@@ -315,7 +356,7 @@ barestmt: PLUGSTMT
}
parser->parsed_sub = 1;
}
- | SUB subname startsub
+ | KW_SUB_named subname startsub
/* sub declaration or definition not within scope
of 'use feature "signatures"'*/
{
@@ -334,79 +375,128 @@ barestmt: PLUGSTMT
intro_my();
parser->parsed_sub = 1;
}
- | SIGSUB subname startsub
+ | sigsub_or_method_named subname startsub
/* sub declaration or definition under 'use feature
* "signatures"'. (Note that a signature isn't
* allowed in a declaration)
*/
{
init_named_cv(PL_compcv, $subname);
+ if($sigsub_or_method_named == KW_METHOD_named) {
+ croak_kw_unless_class("method");
+ class_prepare_method_parse(PL_compcv);
+ }
parser->in_my = 0;
parser->in_my_stash = NULL;
}
subattrlist optsigsubbody
{
+ OP *body = $optsigsubbody;
+
SvREFCNT_inc_simple_void(PL_compcv);
$subname->op_type == OP_CONST
- ? newATTRSUB($startsub, $subname, NULL, $subattrlist, $optsigsubbody)
- : newMYSUB( $startsub, $subname, NULL, $subattrlist, $optsigsubbody)
+ ? newATTRSUB($startsub, $subname, NULL, $subattrlist, body)
+ : newMYSUB( $startsub, $subname, NULL, $subattrlist, body)
;
$$ = NULL;
intro_my();
parser->parsed_sub = 1;
}
- | PACKAGE BAREWORD[version] BAREWORD[package] PERLY_SEMICOLON
+ | PHASER startsub
+ {
+ switch($PHASER) {
+ case KEY_ADJUST:
+ croak_kw_unless_class("ADJUST");
+ class_prepare_method_parse(PL_compcv);
+ break;
+ default:
+ NOT_REACHED;
+ }
+ }
+ optsubbody
+ {
+ OP *body = $optsubbody;
+ SvREFCNT_inc_simple_void(PL_compcv);
+
+ CV *cv;
+
+ switch($PHASER) {
+ case KEY_ADJUST:
+ cv = newATTRSUB($startsub, NULL, NULL, NULL, body);
+ class_add_ADJUST(PL_curstash, cv);
+ break;
+ }
+ $$ = NULL;
+ }
+ | KW_PACKAGE BAREWORD[version] BAREWORD[package] PERLY_SEMICOLON
+ /* version and package appear in the reverse order to what may be
+ * expected, because toke.c has already pushed both of them to a stack
+ * by calling force_next() from within force_version().
+ * When the parser pops them back out again they appear swapped */
+ {
+ package($package);
+ if ($version)
+ package_version($version);
+ $$ = NULL;
+ }
+ | KW_CLASS BAREWORD[version] BAREWORD[package] subattrlist PERLY_SEMICOLON
{
package($package);
if ($version)
package_version($version);
$$ = NULL;
+ class_setup_stash(PL_curstash);
+ if ($subattrlist) {
+ class_apply_attributes(PL_curstash, $subattrlist);
+ }
}
- | USE startsub
+ | KW_USE_or_NO startsub
{ CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ }
BAREWORD[version] BAREWORD[module] optlistexpr PERLY_SEMICOLON
+ /* version and package appear in reverse order for the same reason as
+ * KW_PACKAGE; see comment above */
{
SvREFCNT_inc_simple_void(PL_compcv);
- utilize($USE, $startsub, $version, $module, $optlistexpr);
+ utilize($KW_USE_or_NO, $startsub, $version, $module, $optlistexpr);
parser->parsed_sub = 1;
$$ = NULL;
}
- | IF PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock else
+ | KW_IF PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock else
{
$$ = block_end($remember,
newCONDOP(0, $mexpr, op_scope($mblock), $else));
- parser->copline = (line_t)$IF;
+ parser->copline = (line_t)$KW_IF;
}
- | UNLESS PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock else
+ | KW_UNLESS PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock else
{
$$ = block_end($remember,
newCONDOP(0, $mexpr, $else, op_scope($mblock)));
- parser->copline = (line_t)$UNLESS;
+ parser->copline = (line_t)$KW_UNLESS;
}
- | GIVEN PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock
+ | KW_GIVEN PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock
{
$$ = block_end($remember, newGIVENOP($mexpr, op_scope($mblock), 0));
- parser->copline = (line_t)$GIVEN;
+ parser->copline = (line_t)$KW_GIVEN;
}
- | WHEN PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock
+ | KW_WHEN PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock
{ $$ = block_end($remember, newWHENOP($mexpr, op_scope($mblock))); }
- | DEFAULT block
+ | KW_DEFAULT block
{ $$ = newWHENOP(0, op_scope($block)); }
- | WHILE PERLY_PAREN_OPEN remember texpr PERLY_PAREN_CLOSE mintro mblock cont
+ | KW_WHILE PERLY_PAREN_OPEN remember texpr PERLY_PAREN_CLOSE mintro mblock cont
{
$$ = block_end($remember,
newWHILEOP(0, 1, NULL,
$texpr, $mblock, $cont, $mintro));
- parser->copline = (line_t)$WHILE;
+ parser->copline = (line_t)$KW_WHILE;
}
- | UNTIL PERLY_PAREN_OPEN remember iexpr PERLY_PAREN_CLOSE mintro mblock cont
+ | KW_UNTIL PERLY_PAREN_OPEN remember iexpr PERLY_PAREN_CLOSE mintro mblock cont
{
$$ = block_end($remember,
newWHILEOP(0, 1, NULL,
$iexpr, $mblock, $cont, $mintro));
- parser->copline = (line_t)$UNTIL;
+ parser->copline = (line_t)$KW_UNTIL;
}
- | FOR PERLY_PAREN_OPEN remember mnexpr[init_mnexpr] PERLY_SEMICOLON
+ | KW_FOR PERLY_PAREN_OPEN remember mnexpr[init_mnexpr] PERLY_SEMICOLON
{ parser->expect = XTERM; }
texpr PERLY_SEMICOLON
{ parser->expect = XTERM; }
@@ -424,29 +514,29 @@ barestmt: PLUGSTMT
}
PL_hints |= HINT_BLOCK_SCOPE;
$$ = block_end($remember, forop);
- parser->copline = (line_t)$FOR;
+ parser->copline = (line_t)$KW_FOR;
}
- | FOR MY remember my_scalar PERLY_PAREN_OPEN mexpr PERLY_PAREN_CLOSE mblock cont
+ | KW_FOR KW_MY remember my_scalar PERLY_PAREN_OPEN mexpr PERLY_PAREN_CLOSE mblock cont
{
$$ = block_end($remember, newFOROP(0, $my_scalar, $mexpr, $mblock, $cont));
- parser->copline = (line_t)$FOR;
+ parser->copline = (line_t)$KW_FOR;
}
- | FOR MY remember PERLY_PAREN_OPEN my_list_of_scalars PERLY_PAREN_CLOSE PERLY_PAREN_OPEN mexpr PERLY_PAREN_CLOSE mblock cont
+ | KW_FOR KW_MY remember PERLY_PAREN_OPEN my_list_of_scalars PERLY_PAREN_CLOSE PERLY_PAREN_OPEN mexpr PERLY_PAREN_CLOSE mblock cont
{
if ($my_list_of_scalars->op_type == OP_PADSV)
/* degenerate case of 1 var: for my ($x) ....
Flag it so it can be special-cased in newFOROP */
$my_list_of_scalars->op_flags |= OPf_PARENS;
$$ = block_end($remember, newFOROP(0, $my_list_of_scalars, $mexpr, $mblock, $cont));
- parser->copline = (line_t)$FOR;
+ parser->copline = (line_t)$KW_FOR;
}
- | FOR scalar PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock cont
+ | KW_FOR scalar PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock cont
{
$$ = block_end($remember, newFOROP(0,
op_lvalue($scalar, OP_ENTERLOOP), $mexpr, $mblock, $cont));
- parser->copline = (line_t)$FOR;
+ parser->copline = (line_t)$KW_FOR;
}
- | FOR my_refgen remember my_var
+ | KW_FOR my_refgen remember my_var
{ parser->in_my = 0; $<opval>$ = my($my_var); }[variable]
PERLY_PAREN_OPEN mexpr PERLY_PAREN_CLOSE mblock cont
{
@@ -459,33 +549,36 @@ barestmt: PLUGSTMT
OP_ENTERLOOP),
$mexpr, $mblock, $cont)
);
- parser->copline = (line_t)$FOR;
+ parser->copline = (line_t)$KW_FOR;
}
- | FOR REFGEN refgen_topic PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock cont
+ | KW_FOR REFGEN refgen_topic PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock cont
{
$$ = block_end($remember, newFOROP(
0, op_lvalue(newUNOP(OP_REFGEN, 0,
$refgen_topic),
OP_ENTERLOOP), $mexpr, $mblock, $cont));
- parser->copline = (line_t)$FOR;
+ parser->copline = (line_t)$KW_FOR;
}
- | FOR PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock cont
+ | KW_FOR PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock cont
{
$$ = block_end($remember,
newFOROP(0, NULL, $mexpr, $mblock, $cont));
- parser->copline = (line_t)$FOR;
+ parser->copline = (line_t)$KW_FOR;
}
- | TRY mblock[try] CATCH PERLY_PAREN_OPEN
- { parser->in_my = 1; }
- remember scalar
- { parser->in_my = 0; intro_my(); }
- PERLY_PAREN_CLOSE mblock[catch] finally
+ | KW_TRY mblock[try] KW_CATCH remember catch_paren[scalar]
+ {
+ if(!$scalar) {
+ yyerror("catch block requires a (VAR)");
+ YYERROR;
+ }
+ }
+ mblock[catch] finally
{
$$ = newTRYCATCHOP(0,
$try, $scalar, block_end($remember, op_scope($catch)));
if($finally)
$$ = op_wrap_finally($$, $finally);
- parser->copline = (line_t)$TRY;
+ parser->copline = (line_t)$KW_TRY;
}
| block cont
{
@@ -493,12 +586,32 @@ barestmt: PLUGSTMT
$$ = newWHILEOP(0, 1, NULL,
NULL, $block, $cont, 0);
}
- | PACKAGE BAREWORD[version] BAREWORD[package] PERLY_BRACE_OPEN remember
+ | KW_PACKAGE BAREWORD[version] BAREWORD[package] PERLY_BRACE_OPEN remember
+ {
+ package($package);
+ if ($version) {
+ package_version($version);
+ }
+ }
+ stmtseq PERLY_BRACE_CLOSE
+ {
+ /* a block is a loop that happens once */
+ $$ = newWHILEOP(0, 1, NULL,
+ NULL, block_end($remember, $stmtseq), NULL, 0);
+ if (parser->copline > (line_t)$PERLY_BRACE_OPEN)
+ parser->copline = (line_t)$PERLY_BRACE_OPEN;
+ }
+ | KW_CLASS BAREWORD[version] BAREWORD[package] subattrlist PERLY_BRACE_OPEN remember
{
package($package);
+
if ($version) {
package_version($version);
}
+ class_setup_stash(PL_curstash);
+ if ($subattrlist) {
+ class_apply_attributes(PL_curstash, $subattrlist);
+ }
}
stmtseq PERLY_BRACE_CLOSE
{
@@ -508,16 +621,21 @@ barestmt: PLUGSTMT
if (parser->copline > (line_t)$PERLY_BRACE_OPEN)
parser->copline = (line_t)$PERLY_BRACE_OPEN;
}
+ | fielddecl PERLY_SEMICOLON
+ {
+ $$ = $fielddecl;
+ }
| sideff PERLY_SEMICOLON
{
$$ = $sideff;
}
- | DEFER mblock
+ | KW_DEFER mblock
{
$$ = newDEFEROP(0, op_scope($2));
}
| YADAYADA PERLY_SEMICOLON
{
+ /* diag_listed_as: Unimplemented */
$$ = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
newSVOP(OP_CONST, 0, newSVpvs("Unimplemented")));
}
@@ -560,31 +678,31 @@ sideff : error
{ $$ = NULL; }
| expr[body]
{ $$ = $body; }
- | expr[body] IF condition
+ | expr[body] KW_IF condition
{ $$ = newLOGOP(OP_AND, 0, $condition, $body); }
- | expr[body] UNLESS condition
+ | expr[body] KW_UNLESS condition
{ $$ = newLOGOP(OP_OR, 0, $condition, $body); }
- | expr[body] WHILE condition
+ | expr[body] KW_WHILE condition
{ $$ = newLOOPOP(OPf_PARENS, 1, scalar($condition), $body); }
- | expr[body] UNTIL iexpr
+ | expr[body] KW_UNTIL iexpr
{ $$ = newLOOPOP(OPf_PARENS, 1, $iexpr, $body); }
- | expr[body] FOR condition
+ | expr[body] KW_FOR condition
{ $$ = newFOROP(0, NULL, $condition, $body, NULL);
- parser->copline = (line_t)$FOR; }
- | expr[body] WHEN condition
+ parser->copline = (line_t)$KW_FOR; }
+ | expr[body] KW_WHEN condition
{ $$ = newWHENOP($condition, op_scope($body)); }
;
/* else and elsif blocks */
else
: empty
- | ELSE mblock
+ | KW_ELSE mblock
{
($mblock)->op_flags |= OPf_PARENS;
$$ = op_scope($mblock);
}
- | ELSIF PERLY_PAREN_OPEN mexpr PERLY_PAREN_CLOSE mblock else[else.recurse]
- { parser->copline = (line_t)$ELSIF;
+ | KW_ELSIF PERLY_PAREN_OPEN mexpr PERLY_PAREN_CLOSE mblock else[else.recurse]
+ { parser->copline = (line_t)$KW_ELSIF;
$$ = newCONDOP(0,
newSTATEOP(OPf_SPECIAL,NULL,$mexpr),
op_scope($mblock), $[else.recurse]);
@@ -595,14 +713,14 @@ else
/* Continue blocks */
cont
: empty
- | CONTINUE block
+ | KW_CONTINUE block
{ $$ = op_scope($block); }
;
/* Finally blocks */
finally : %empty
{ $$ = NULL; }
- | FINALLY block
+ | KW_FINALLY block
{ $$ = op_scope($block); }
;
@@ -655,6 +773,11 @@ startanonsub: %empty /* start an anonymous subroutine scope */
SAVEFREESV(PL_compcv); }
;
+startanonmethod: %empty /* start an anonymous method scope */
+ { $$ = start_subparse(FALSE, CVf_ANON|CVf_IsMETHOD);
+ SAVEFREESV(PL_compcv); }
+ ;
+
startformsub: %empty /* start a format subroutine scope */
{ $$ = start_subparse(TRUE, 0);
SAVEFREESV(PL_compcv); }
@@ -675,7 +798,12 @@ proto
subattrlist
: empty
| COLONATTR THING
- { $$ = $THING; }
+ {
+ OP *attrlist = $THING;
+ if(attrlist && !PL_parser->sig_seen)
+ attrlist = apply_builtin_cv_attributes(PL_compcv, attrlist);
+ $$ = attrlist;
+ }
| COLONATTR
{ $$ = NULL; }
;
@@ -709,15 +837,15 @@ sigslurpsigil:
/* @, %, @foo, %foo */
sigslurpelem: sigslurpsigil sigvarname sigdefault/* def only to catch errors */
{
- I32 sigil = $sigslurpsigil;
- OP *var = $sigvarname;
- OP *defexpr = $sigdefault;
+ I32 sigil = $sigslurpsigil;
+ OP *var = $sigvarname;
+ OP *defop = $sigdefault;
if (parser->sig_slurpy)
yyerror("Multiple slurpy parameters not allowed");
parser->sig_slurpy = (char)sigil;
- if (defexpr)
+ if (defop)
yyerror("A slurpy parameter may not have "
"a default value");
@@ -729,26 +857,35 @@ sigslurpelem: sigslurpsigil sigvarname sigdefault/* def only to catch errors */
sigdefault
: empty
| ASSIGNOP
- { $$ = newOP(OP_NULL, 0); }
+ { $$ = newARGDEFELEMOP(0, newOP(OP_NULL, 0), parser->sig_elems); }
| ASSIGNOP term
- { $$ = $term; }
+ {
+ I32 flags = 0;
+ if ($ASSIGNOP == OP_DORASSIGN)
+ flags |= OPpARG_IF_UNDEF << 8;
+ if ($ASSIGNOP == OP_ORASSIGN)
+ flags |= OPpARG_IF_FALSE << 8;
+ $$ = newARGDEFELEMOP(flags, $term, parser->sig_elems);
+ }
/* subroutine signature scalar element: e.g. '$x', '$=', '$x = $default' */
sigscalarelem:
PERLY_DOLLAR sigvarname sigdefault
{
- OP *var = $sigvarname;
- OP *defexpr = $sigdefault;
+ OP *var = $sigvarname;
+ OP *defop = $sigdefault;
if (parser->sig_slurpy)
yyerror("Slurpy parameter not last");
parser->sig_elems++;
- if (defexpr) {
+ if (defop) {
parser->sig_optelems++;
+ OP *defexpr = cLOGOPx(defop)->op_first;
+
if ( defexpr->op_type == OP_NULL
&& !(defexpr->op_flags & OPf_KIDS))
{
@@ -756,17 +893,10 @@ sigscalarelem:
if (var)
yyerror("Optional parameter "
"lacks default expression");
- op_free(defexpr);
+ op_free(defop);
}
else {
/* a normal '=default' expression */
- OP *defop = (OP*)alloc_LOGOP(OP_ARGDEFELEM,
- defexpr,
- LINKLIST(defexpr));
- /* re-purpose op_targ to hold @_ index */
- defop->op_targ =
- (PADOFFSET)(parser->sig_elems - 1);
-
if (var) {
var->op_flags |= OPf_STACKED;
(void)op_sibling_splice(var,
@@ -852,7 +982,7 @@ subsigguts:
struct op_argcheck_aux *aux;
OP *check;
- if (!FEATURE_SIGNATURES_IS_ENABLED)
+ if (!FEATURE_SIGNATURES_IS_ENABLED && !CvIsMETHOD(PL_compcv))
Perl_croak(aTHX_ "Experimental "
"subroutine signatures not enabled");
@@ -939,8 +1069,12 @@ sigsubbody: remember optsubsignature PERLY_BRACE_OPEN stmtseq PERLY_BRACE_CLOSE
/* Ordinary expressions; logical combinations */
expr : expr[lhs] ANDOP expr[rhs]
{ $$ = newLOGOP(OP_AND, 0, $lhs, $rhs); }
+ | expr[lhs] PLUGIN_LOGICAL_AND_LOW_OP[op] expr[rhs]
+ { $$ = build_infix_plugin($lhs, $rhs, $op); }
| expr[lhs] OROP[operator] expr[rhs]
{ $$ = newLOGOP($operator, 0, $lhs, $rhs); }
+ | expr[lhs] PLUGIN_LOGICAL_OR_LOW_OP[op] expr[rhs]
+ { $$ = build_infix_plugin($lhs, $rhs, $op); }
| listexpr %prec PREC_LOW
;
@@ -964,28 +1098,28 @@ listop : LSTOP indirob listexpr /* map {...} @args or print $fh @args */
{ $$ = op_convert_list($FUNC, OPf_STACKED,
op_prepend_elem(OP_LIST, newGVREF($FUNC,$indirob), $expr) );
}
- | term ARROW method PERLY_PAREN_OPEN optexpr PERLY_PAREN_CLOSE /* $foo->bar(list) */
+ | term ARROW methodname PERLY_PAREN_OPEN optexpr PERLY_PAREN_CLOSE /* $foo->bar(list) */
{ $$ = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, scalar($term), $optexpr),
- newMETHOP(OP_METHOD, 0, $method)));
+ newMETHOP(OP_METHOD, 0, $methodname)));
}
- | term ARROW method /* $foo->bar */
+ | term ARROW methodname /* $foo->bar */
{ $$ = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, scalar($term),
- newMETHOP(OP_METHOD, 0, $method)));
+ newMETHOP(OP_METHOD, 0, $methodname)));
}
- | METHOD indirob optlistexpr /* new Class @args */
+ | METHCALL0 indirob optlistexpr /* new Class @args */
{ $$ = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, $indirob, $optlistexpr),
- newMETHOP(OP_METHOD, 0, $METHOD)));
+ newMETHOP(OP_METHOD, 0, $METHCALL0)));
}
- | FUNCMETH indirob PERLY_PAREN_OPEN optexpr PERLY_PAREN_CLOSE /* method $object (@args) */
+ | METHCALL indirob PERLY_PAREN_OPEN optexpr PERLY_PAREN_CLOSE /* method $object (@args) */
{ $$ = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, $indirob, $optexpr),
- newMETHOP(OP_METHOD, 0, $FUNCMETH)));
+ newMETHOP(OP_METHOD, 0, $METHCALL)));
}
| LSTOP optlistexpr /* print @args */
{ $$ = op_convert_list($LSTOP, 0, $optlistexpr); }
@@ -1004,7 +1138,7 @@ listop : LSTOP indirob listexpr /* map {...} @args or print $fh @args */
;
/* Names of methods. May use $object->$methodname */
-method : METHOD
+methodname: METHCALL0
| scalar
;
@@ -1073,17 +1207,27 @@ subscripted: gelem PERLY_BRACE_OPEN expr PERLY_SEMICOLON PERLY_BRACE_CLOSE
;
/* Binary operators between terms */
-termbinop: term[lhs] ASSIGNOP term[rhs] /* $x = $y, $x += $y */
+termbinop: term[lhs] PLUGIN_HIGH_OP[op] term[rhs]
+ { $$ = build_infix_plugin($lhs, $rhs, $op); }
+ | term[lhs] ASSIGNOP term[rhs] /* $x = $y, $x += $y */
{ $$ = newASSIGNOP(OPf_STACKED, $lhs, $ASSIGNOP, $rhs); }
+ | term[lhs] PLUGIN_ASSIGN_OP[op] term[rhs]
+ { $$ = build_infix_plugin($lhs, $rhs, $op); }
| term[lhs] POWOP term[rhs] /* $x ** $y */
{ $$ = newBINOP($POWOP, 0, scalar($lhs), scalar($rhs)); }
+ | term[lhs] PLUGIN_POW_OP[op] term[rhs]
+ { $$ = build_infix_plugin($lhs, $rhs, $op); }
| term[lhs] MULOP term[rhs] /* $x * $y, $x x $y */
{ if ($MULOP != OP_REPEAT)
scalar($lhs);
$$ = newBINOP($MULOP, 0, $lhs, scalar($rhs));
}
+ | term[lhs] PLUGIN_MUL_OP[op] term[rhs]
+ { $$ = build_infix_plugin($lhs, $rhs, $op); }
| term[lhs] ADDOP term[rhs] /* $x + $y */
{ $$ = newBINOP($ADDOP, 0, scalar($lhs), scalar($rhs)); }
+ | term[lhs] PLUGIN_ADD_OP[op] term[rhs]
+ { $$ = build_infix_plugin($lhs, $rhs, $op); }
| term[lhs] SHIFTOP term[rhs] /* $x >> $y, $x << $y */
{ $$ = newBINOP($SHIFTOP, 0, scalar($lhs), scalar($rhs)); }
| termrelop %prec PREC_LOW /* $x > $y, etc. */
@@ -1098,12 +1242,18 @@ termbinop: term[lhs] ASSIGNOP term[rhs] /* $x = $y, $x += $y
{ $$ = newRANGE($DOTDOT, scalar($lhs), scalar($rhs)); }
| term[lhs] ANDAND term[rhs] /* $x && $y */
{ $$ = newLOGOP(OP_AND, 0, $lhs, $rhs); }
+ | term[lhs] PLUGIN_LOGICAL_AND_OP[op] term[rhs]
+ { $$ = build_infix_plugin($lhs, $rhs, $op); }
| term[lhs] OROR term[rhs] /* $x || $y */
{ $$ = newLOGOP(OP_OR, 0, $lhs, $rhs); }
+ | term[lhs] PLUGIN_LOGICAL_OR_OP[op] term[rhs]
+ { $$ = build_infix_plugin($lhs, $rhs, $op); }
| term[lhs] DORDOR term[rhs] /* $x // $y */
{ $$ = newLOGOP(OP_DOR, 0, $lhs, $rhs); }
| term[lhs] MATCHOP term[rhs] /* $x =~ /$y/ */
{ $$ = bind_match($MATCHOP, $lhs, $rhs); }
+ | term[lhs] PLUGIN_LOW_OP[op] term[rhs]
+ { $$ = build_infix_plugin($lhs, $rhs, $op); }
;
termrelop: relopchain %prec PREC_LOW
@@ -1114,6 +1264,8 @@ termrelop: relopchain %prec PREC_LOW
{ yyerror("syntax error"); YYERROR; }
| termrelop CHRELOP
{ yyerror("syntax error"); YYERROR; }
+ | term[lhs] PLUGIN_REL_OP[op] term[rhs]
+ { $$ = build_infix_plugin($lhs, $rhs, $op); }
;
relopchain: term[lhs] CHRELOP term[rhs]
@@ -1180,18 +1332,23 @@ anonymous
{ $$ = newANONLIST($optexpr); }
| HASHBRACK optexpr PERLY_SEMICOLON PERLY_BRACE_CLOSE %prec PERLY_PAREN_OPEN /* { foo => "Bar" } */
{ $$ = newANONHASH($optexpr); }
- | ANONSUB startanonsub proto subattrlist subbody %prec PERLY_PAREN_OPEN
+ | KW_SUB_anon startanonsub proto subattrlist subbody %prec PERLY_PAREN_OPEN
{ SvREFCNT_inc_simple_void(PL_compcv);
$$ = newANONATTRSUB($startanonsub, $proto, $subattrlist, $subbody); }
- | ANON_SIGSUB startanonsub subattrlist sigsubbody %prec PERLY_PAREN_OPEN
+ | KW_SUB_anon_sig startanonsub subattrlist sigsubbody %prec PERLY_PAREN_OPEN
{ SvREFCNT_inc_simple_void(PL_compcv);
$$ = newANONATTRSUB($startanonsub, NULL, $subattrlist, $sigsubbody); }
+ | KW_METHOD_anon startanonmethod subattrlist sigsubbody %prec PERLY_PAREN_OPEN
+ {
+ SvREFCNT_inc_simple_void(PL_compcv);
+ $$ = newANONATTRSUB($startanonmethod, NULL, $subattrlist, $sigsubbody);
+ }
;
/* Things called with "do" */
-termdo : DO term %prec UNIOP /* do $filename */
- { $$ = dofile($term, $DO);}
- | DO block %prec PERLY_PAREN_OPEN /* do { code */
+termdo : KW_DO term %prec UNIOP /* do $filename */
+ { $$ = dofile($term, $KW_DO);}
+ | KW_DO block %prec PERLY_PAREN_OPEN /* do { code */
{ $$ = newUNOP(OP_NULL, OPf_SPECIAL, op_scope($block));}
;
@@ -1205,7 +1362,7 @@ term[product] : termbinop
{ $$ = newUNOP(OP_REFGEN, 0, $operand); }
| myattrterm %prec UNIOP
{ $$ = $myattrterm; }
- | LOCAL term[operand] %prec UNIOP
+ | KW_LOCAL term[operand] %prec UNIOP
{ $$ = localize($operand,0); }
| PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE
{ $$ = sawparens($expr); }
@@ -1305,10 +1462,10 @@ term[product] : termbinop
{ $$ = newUNOP($UNIOP, 0, $block); }
| UNIOP term[operand] /* Unary op */
{ $$ = newUNOP($UNIOP, 0, $operand); }
- | REQUIRE /* require, $_ implied */
- { $$ = newOP(OP_REQUIRE, $REQUIRE ? OPf_SPECIAL : 0); }
- | REQUIRE term[operand] /* require Foo */
- { $$ = newUNOP(OP_REQUIRE, $REQUIRE ? OPf_SPECIAL : 0, $operand); }
+ | KW_REQUIRE /* require, $_ implied */
+ { $$ = newOP(OP_REQUIRE, $KW_REQUIRE ? OPf_SPECIAL : 0); }
+ | KW_REQUIRE term[operand] /* require Foo */
+ { $$ = newUNOP(OP_REQUIRE, $KW_REQUIRE ? OPf_SPECIAL : 0, $operand); }
| UNIOPSUB
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($UNIOPSUB)); }
| UNIOPSUB term[operand] /* Sub treated as unop */
@@ -1350,13 +1507,13 @@ term[product] : termbinop
/* "my" declarations, with optional attributes */
myattrterm
- : MY myterm myattrlist
+ : KW_MY myterm myattrlist
{ $$ = my_attrs($myterm,$myattrlist); }
- | MY myterm
+ | KW_MY myterm
{ $$ = localize($myterm,1); }
- | MY REFGEN myterm myattrlist
+ | KW_MY REFGEN myterm myattrlist
{ $$ = newUNOP(OP_REFGEN, 0, my_attrs($myterm,$myattrlist)); }
- | MY REFGEN term[operand]
+ | KW_MY REFGEN term[operand]
{ $$ = newUNOP(OP_REFGEN, 0, localize($operand,1)); }
;
@@ -1374,6 +1531,56 @@ myterm : PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE
{ $$ = $ary; }
;
+/* "field" declarations */
+fieldvar: scalar %prec PERLY_PAREN_OPEN
+ {
+ $$ = PadnamelistARRAY(PL_comppad_name)[$scalar->op_targ];
+ op_free($scalar);
+ }
+ | hsh %prec PERLY_PAREN_OPEN
+ {
+ $$ = PadnamelistARRAY(PL_comppad_name)[$hsh->op_targ];
+ op_free($hsh);
+ }
+ | ary %prec PERLY_PAREN_OPEN
+ {
+ $$ = PadnamelistARRAY(PL_comppad_name)[$ary->op_targ];
+ op_free($ary);
+ }
+ ;
+
+optfieldattrlist:
+ COLONATTR THING
+ { $$ = $THING; }
+ | COLONATTR
+ { $$ = NULL; }
+ | empty
+ ;
+
+fielddecl
+ : KW_FIELD fieldvar optfieldattrlist
+ {
+ parser->in_my = 0;
+ if($optfieldattrlist)
+ class_apply_field_attributes((PADNAME *)$fieldvar, $optfieldattrlist);
+ $$ = newOP(OP_NULL, 0);
+ }
+ | KW_FIELD fieldvar optfieldattrlist ASSIGNOP
+ {
+ parser->in_my = 0;
+ if($optfieldattrlist)
+ class_apply_field_attributes((PADNAME *)$fieldvar, $optfieldattrlist);
+ ENTER;
+ class_prepare_initfield_parse();
+ }
+ term
+ {
+ class_set_field_defop((PADNAME *)$fieldvar, $ASSIGNOP, $term);
+ LEAVE;
+ $$ = newOP(OP_NULL, 0);
+ }
+ ;
+
/* Basic list expressions */
optlistexpr
: empty %prec PREC_LOW
@@ -1419,8 +1626,8 @@ refgen_topic: my_var
| amper
;
-my_refgen: MY REFGEN
- | REFGEN MY
+my_refgen: KW_MY REFGEN
+ | REFGEN KW_MY
;
amper : PERLY_AMPERSAND indirob