diff options
author | Andrew Fresh <afresh1@cvs.openbsd.org> | 2024-05-14 19:39:02 +0000 |
---|---|---|
committer | Andrew Fresh <afresh1@cvs.openbsd.org> | 2024-05-14 19:39:02 +0000 |
commit | 45c703581717284c37fbb2abc2968de039f80a64 (patch) | |
tree | 4bc6b627547b709d1beaa366b98c92444fe5c5b8 /gnu/usr.bin/perl/perly.y | |
parent | 0aa19f5e10f3aa68dc15f265cb9e764af0950d32 (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.y | 447 |
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 |