1/* vi: set ft=c : */ 2 3#ifndef parse_subsignature 4 5#define PERL_EXT 6#include "feature.h" 7 8#include "make_argcheck_aux.c.inc" 9 10/* 11 * Need to grab some things that aren't quite core perl API 12 */ 13 14/* yyerror() is a long function and hard to emulate or copy-paste for our 15 * purposes; we'll reïmplement a smaller version of it 16 */ 17 18#define LEX_IGNORE_UTF8_HINTS 0x00000002 19 20#define PL_linestr (PL_parser->linestr) 21 22#ifdef USE_UTF8_SCRIPTS 23# define UTF cBOOL(!IN_BYTES) 24#else 25# define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8))) 26#endif 27 28#define yyerror(s) S_yyerror(aTHX_ s) 29void S_yyerror(pTHX_ const char *s) 30{ 31 SV *message = sv_2mortal(newSVpvs_flags("", 0)); 32 33 char *context = PL_parser->oldbufptr; 34 STRLEN contlen = PL_parser->bufptr - PL_parser->oldbufptr; 35 36 sv_catpvf(message, "%s at %s line %" IVdf, 37 s, OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 38 39 if(context) 40 sv_catpvf(message, ", near \"%" UTF8f "\"", 41 UTF8fARG(UTF, contlen, context)); 42 43 sv_catpvf(message, "\n"); 44 45 PL_parser->error_count++; 46 warn_sv(message); 47} 48 49/* Stolen from op.c */ 50#define OpTYPE_set(op, type) \ 51 STMT_START { \ 52 op->op_type = (OPCODE)type; \ 53 op->op_ppaddr = PL_ppaddr[type]; \ 54 } STMT_END 55 56#define alloc_LOGOP(a,b,c) S_alloc_LOGOP(aTHX_ a,b,c) 57static LOGOP *S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) 58{ 59 dVAR; 60 LOGOP *logop; 61 OP *kid = first; 62 NewOp(1101, logop, 1, LOGOP); 63 OpTYPE_set(logop, type); 64 logop->op_first = first; 65 logop->op_other = other; 66 if (first) 67 logop->op_flags = OPf_KIDS; 68 while (kid && OpHAS_SIBLING(kid)) 69 kid = OpSIBLING(kid); 70 if (kid) 71 OpLASTSIB_set(kid, (OP*)logop); 72 return logop; 73} 74 75#define parse_sigelem() S_parse_sigelem(aTHX) 76static OP *S_parse_sigelem(pTHX) 77{ 78 yy_parser *parser = PL_parser; 79 80 int c = lex_peek_unichar(0); 81 int flags; 82 83 switch(c) { 84 case '$': flags = OPpARGELEM_SV; break; 85 case '@': flags = OPpARGELEM_AV; break; 86 case '%': flags = OPpARGELEM_HV; break; 87 default: 88 croak("Expected a signature element at <%s>\n", parser->bufptr); 89 } 90 91 char *lexname = parser->bufptr; 92 OP *varop = NULL; 93 94 /* Consume sigil */ 95 lex_read_unichar(0); 96 97 if(isIDFIRST_uni(lex_peek_unichar(0))) { 98 lex_read_unichar(0); 99 while(isALNUM_uni(lex_peek_unichar(0))) 100 lex_read_unichar(0); 101 102 varop = newUNOP_AUX(OP_ARGELEM, 0, NULL, INT2PTR(UNOP_AUX_item *, (parser->sig_elems))); 103 varop->op_private |= flags; 104 105 varop->op_targ = pad_add_name_pvn(lexname, PL_parser->bufptr - lexname, 0, NULL, NULL); 106 107 lex_read_space(0); 108 } 109 110 if(c == '$') { 111 if(parser->sig_slurpy) 112 yyerror("Slurpy parameters not last"); 113 114 parser->sig_elems++; 115 116 if(lex_peek_unichar(0) == '=') { 117 lex_read_unichar(0); 118 lex_read_space(0); 119 120 parser->sig_optelems++; 121 122 OP *defexpr = parse_termexpr(0); 123 124 OP *defop = (OP *)alloc_LOGOP(OP_ARGDEFELEM, defexpr, LINKLIST(defexpr)); 125 defop->op_targ = (PADOFFSET)(parser->sig_elems - 1); 126 127 varop->op_flags |= OPf_STACKED; 128 op_sibling_splice(varop, NULL, 0, defop); 129 defop = op_contextualize(defop, G_SCALAR); 130 131 LINKLIST(varop); 132 133 varop->op_next = defop; 134 defexpr->op_next = varop; 135 } 136 else { 137 if(parser->sig_optelems) 138 yyerror("Mandatory parameter follows optional parameter"); 139 } 140 } 141 else { 142 if(parser->sig_slurpy) 143 yyerror("Multiple slurpy parameters not allowed"); 144 145 parser->sig_slurpy = c; 146 147 if(lex_peek_unichar(0) == '=') 148 yyerror("A slurpy parameter may not have a default value"); 149 } 150 151 return varop ? newSTATEOP(0, NULL, varop) : NULL; 152} 153 154#define parse_subsignature(flags) S_parse_subsignature(aTHX_ flags) 155static OP *S_parse_subsignature(pTHX_ int flags) 156{ 157 /* Mostly reconstructed logic from perl 5.28.0's toke.c and perly.y 158 */ 159 yy_parser *parser = PL_parser; 160 161 ENTER; 162 SAVEIV(parser->sig_elems); 163 SAVEIV(parser->sig_optelems); 164 SAVEI8(parser->sig_slurpy); 165 166 parser->sig_elems = 0; 167 parser->sig_optelems = 0; 168 parser->sig_slurpy = 0; 169 170 OP *elems = NULL; 171 while(lex_peek_unichar(0) != ')') { 172 lex_read_space(0); 173 OP *elem = parse_sigelem(); 174 elems = op_append_list(OP_LINESEQ, elems, elem); 175 176 if(PL_parser->error_count) { 177 LEAVE; 178 return NULL; 179 } 180 181 lex_read_space(0); 182 switch(lex_peek_unichar(0)) { 183 case ')': goto endofelems; 184 case ',': break; 185 default: 186 fprintf(stderr, "ARGH unsure how to proceed parse_subsignature at <%s>\n", 187 parser->bufptr); 188 croak("ARGH"); 189 break; 190 } 191 192 lex_read_unichar(0); 193 lex_read_space(0); 194 } 195endofelems: 196 197 if (!FEATURE_SIGNATURES_IS_ENABLED) 198 croak("Experimental subroutine signatures not enabled"); 199 200 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__SIGNATURES), 201 "The signatures feature is experimental"); 202 203 UNOP_AUX_item *aux = make_argcheck_aux( 204 parser->sig_elems, parser->sig_optelems, parser->sig_slurpy); 205 206 OP *checkop = newUNOP_AUX(OP_ARGCHECK, 0, NULL, aux); 207 208 checkop = op_prepend_elem(OP_LINESEQ, newSTATEOP(0, NULL, NULL), 209 op_prepend_elem(OP_LINESEQ, checkop, elems)); 210 211 /* a nextstate at the end handles context correctly for an empty 212 * sub body */ 213 checkop = op_append_elem(OP_LINESEQ, checkop, newSTATEOP(0, NULL, NULL)); 214 215 LEAVE; 216 217 return checkop; 218} 219 220#endif 221