projects / p5sagit/Function-Parameters.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
use UVs instead of strings where possible
[p5sagit/Function-Parameters.git] / Parameters.xs
CommitLineData
db81d362 1/*
2Copyright 2012 Lukas Mai.
3
4This program is free software; you can redistribute it and/or modify it
5under the terms of either: the GNU General Public License as published
6by the Free Software Foundation; or the Artistic License.
7
8See http://dev.perl.org/licenses/ for more information.
9 */
10
11#ifdef __GNUC__
12 #if (__GNUC__ == 4 && __GNUC_MINOR__ >= 6) || __GNUC__ >= 5
13 #define PRAGMA_GCC_(X) _Pragma(#X)
14 #define PRAGMA_GCC(X) PRAGMA_GCC_(GCC X)
15 #endif
16#endif
17
18#ifndef PRAGMA_GCC
19 #define PRAGMA_GCC(X)
20#endif
21
22#ifdef DEVEL
23 #define WARNINGS_RESET PRAGMA_GCC(diagnostic pop)
24 #define WARNINGS_ENABLEW(X) PRAGMA_GCC(diagnostic warning #X)
25 #define WARNINGS_ENABLE \
26 WARNINGS_ENABLEW(-Wall) \
27 WARNINGS_ENABLEW(-Wextra) \
28 WARNINGS_ENABLEW(-Wundef) \
c3e72f35 29 /* WARNINGS_ENABLEW(-Wshadow) :-( */ \
db81d362 30 WARNINGS_ENABLEW(-Wbad-function-cast) \
31 WARNINGS_ENABLEW(-Wcast-align) \
32 WARNINGS_ENABLEW(-Wwrite-strings) \
33 /* WARNINGS_ENABLEW(-Wnested-externs) wtf? */ \
34 WARNINGS_ENABLEW(-Wstrict-prototypes) \
35 WARNINGS_ENABLEW(-Wmissing-prototypes) \
36 WARNINGS_ENABLEW(-Winline) \
37 WARNINGS_ENABLEW(-Wdisabled-optimization)
38
39#else
40 #define WARNINGS_RESET
1bc47886 41 #define WARNINGS_ENABLE
db81d362 42#endif
43
44
7dd35535 45#define PERL_NO_GET_CONTEXT
db81d362 46#include "EXTERN.h"
47#include "perl.h"
48#include "XSUB.h"
49
50#include <string.h>
51
63915d26 52
db81d362 53WARNINGS_ENABLE
54
db81d362 55
7dd35535 56#define HAVE_PERL_VERSION(R, V, S) \
57 (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
58
de013990 59#if HAVE_PERL_VERSION(5, 16, 0)
60 #define IF_HAVE_PERL_5_16(YES, NO) YES
61#else
62 #define IF_HAVE_PERL_5_16(YES, NO) NO
63#endif
64
e158cf8f 65#if 0
66 #if HAVE_PERL_VERSION(5, 17, 6)
67 #error "internal error: missing definition of KEY_my (your perl is too new)"
68 #elif HAVE_PERL_VERSION(5, 15, 8)
69 #define S_KEY_my 134
70 #elif HAVE_PERL_VERSION(5, 15, 6)
71 #define S_KEY_my 133
72 #elif HAVE_PERL_VERSION(5, 15, 5)
73 #define S_KEY_my 132
74 #elif HAVE_PERL_VERSION(5, 13, 0)
75 #define S_KEY_my 131
76 #else
77 #error "internal error: missing definition of KEY_my (your perl is too old)"
78 #endif
79#endif
80
63915d26 81
82#define MY_PKG "Function::Parameters"
83
84#define HINTK_KEYWORDS MY_PKG "/keywords"
85#define HINTK_FLAGS_ MY_PKG "/flags:"
86#define HINTK_SHIFT_ MY_PKG "/shift:"
87#define HINTK_ATTRS_ MY_PKG "/attrs:"
88
89#define DEFSTRUCT(T) typedef struct T T; struct T
90
0f875412 91#define UV_BITS (sizeof (UV) * CHAR_BIT)
92
63915d26 93enum {
94 FLAG_NAME_OK = 0x01,
95 FLAG_ANON_OK = 0x02,
96 FLAG_DEFAULT_ARGS = 0x04,
d8e5d540 97 FLAG_CHECK_NARGS = 0x08,
e158cf8f 98 FLAG_INVOCANT = 0x10,
99 FLAG_NAMED_PARAMS = 0x20
63915d26 100};
101
102DEFSTRUCT(KWSpec) {
103 unsigned flags;
b72eb6ee 104 SV *shift;
105 SV *attrs;
63915d26 106};
db81d362 107
108static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
109
63915d26 110static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, KWSpec *spec) {
db81d362 111 HV *hints;
112 SV *sv, **psv;
113 const char *p, *kw_active;
114 STRLEN kw_active_len;
115
63915d26 116 spec->flags = 0;
b72eb6ee 117 spec->shift = sv_2mortal(newSVpvs(""));
118 spec->attrs = sv_2mortal(newSVpvs(""));
db81d362 119
120 if (!(hints = GvHV(PL_hintgv))) {
121 return FALSE;
122 }
123 if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
124 return FALSE;
125 }
126 sv = *psv;
127 kw_active = SvPV(sv, kw_active_len);
128 if (kw_active_len <= kw_len) {
129 return FALSE;
130 }
e88490f6 131 for (
132 p = kw_active;
133 (p = strchr(p, *kw_ptr)) &&
134 p < kw_active + kw_active_len - kw_len;
135 p++
136 ) {
db81d362 137 if (
138 (p == kw_active || p[-1] == ' ') &&
139 p[kw_len] == ' ' &&
140 memcmp(kw_ptr, p, kw_len) == 0
141 ) {
b72eb6ee 142
d970c3e7 143#define FETCH_HINTK_INTO(NAME, PTR, LEN, X) STMT_START { \
b72eb6ee 144 const char *fk_ptr_; \
145 STRLEN fk_len_; \
146 SV *fk_sv_; \
147 fk_sv_ = sv_2mortal(newSVpvs(HINTK_ ## NAME)); \
148 sv_catpvn(fk_sv_, PTR, LEN); \
149 fk_ptr_ = SvPV(fk_sv_, fk_len_); \
150 if (!((X) = hv_fetch(hints, fk_ptr_, fk_len_, 0))) { \
151 croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)fk_len_, fk_ptr_); \
152 } \
d970c3e7 153} STMT_END
b72eb6ee 154
63915d26 155 FETCH_HINTK_INTO(FLAGS_, kw_ptr, kw_len, psv);
156 spec->flags = SvIV(*psv);
db81d362 157
b72eb6ee 158 FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv);
159 SvSetSV(spec->shift, *psv);
db81d362 160
b72eb6ee 161 FETCH_HINTK_INTO(ATTRS_, kw_ptr, kw_len, psv);
162 SvSetSV(spec->attrs, *psv);
163
164#undef FETCH_HINTK_INTO
db81d362 165 return TRUE;
166 }
167 }
168 return FALSE;
169}
170
171
311ced6f 172static void free_ptr_op(pTHX_ void *vp) {
c311cef3 173 OP **pp = vp;
174 op_free(*pp);
175 Safefree(pp);
176}
177
59016bfb 178#define sv_eq_pvs(SV, S) my_sv_eq_pvn(aTHX_ SV, "" S "", sizeof (S) - 1)
c311cef3 179
59016bfb 180static int my_sv_eq_pvn(pTHX_ SV *sv, const char *p, STRLEN n) {
c311cef3 181 STRLEN sv_len;
182 const char *sv_p = SvPV(sv, sv_len);
59016bfb 183 return memcmp(sv_p, p, n) == 0;
c311cef3 184}
185
186
187#include "padop_on_crack.c.inc"
188
189
c311cef3 190enum {
191 MY_ATTR_LVALUE = 0x01,
192 MY_ATTR_METHOD = 0x02,
193 MY_ATTR_SPECIAL = 0x04
194};
195
31534187 196static void my_sv_cat_c(pTHX_ SV *sv, U32 c) {
197 char ds[UTF8_MAXBYTES + 1], *d;
198 d = uvchr_to_utf8(ds, c);
199 if (d - ds > 1) {
200 sv_utf8_upgrade(sv);
201 }
202 sv_catpvn(sv, ds, d - ds);
203}
204
205static bool my_is_uni_xidfirst(pTHX_ UV c) {
206 U8 tmpbuf[UTF8_MAXBYTES + 1];
207 uvchr_to_utf8(tmpbuf, c);
208 return is_utf8_xidfirst(tmpbuf);
209}
210
211static bool my_is_uni_xidcont(pTHX_ UV c) {
212 U8 tmpbuf[UTF8_MAXBYTES + 1];
213 uvchr_to_utf8(tmpbuf, c);
214 return is_utf8_xidcont(tmpbuf);
215}
216
217static SV *my_scan_word(pTHX_ bool allow_package) {
218 bool at_start, at_substart;
219 I32 c;
220 SV *sv = sv_2mortal(newSVpvs(""));
221 if (lex_bufutf8()) {
222 SvUTF8_on(sv);
223 }
224
225 at_start = at_substart = TRUE;
226 c = lex_peek_unichar(0);
227
228 while (c != -1) {
229 if (at_substart ? my_is_uni_xidfirst(aTHX_ c) : my_is_uni_xidcont(aTHX_ c)) {
230 lex_read_unichar(0);
231 my_sv_cat_c(aTHX_ sv, c);
232 at_substart = FALSE;
233 c = lex_peek_unichar(0);
234 } else if (allow_package && !at_substart && c == '\'') {
235 lex_read_unichar(0);
236 c = lex_peek_unichar(0);
237 if (!my_is_uni_xidfirst(aTHX_ c)) {
238 lex_stuff_pvs("'", 0);
239 break;
240 }
241 sv_catpvs(sv, "'");
242 at_substart = TRUE;
243 } else if (allow_package && (at_start || !at_substart) && c == ':') {
244 lex_read_unichar(0);
245 if (lex_peek_unichar(0) != ':') {
246 lex_stuff_pvs(":", 0);
247 break;
248 }
249 lex_read_unichar(0);
250 c = lex_peek_unichar(0);
251 if (!my_is_uni_xidfirst(aTHX_ c)) {
252 lex_stuff_pvs("::", 0);
253 break;
254 }
255 sv_catpvs(sv, "::");
256 at_substart = TRUE;
257 } else {
258 break;
259 }
260 at_start = FALSE;
261 }
262
263 return SvCUR(sv) ? sv : NULL;
264}
265
266static SV *my_scan_parens_tail(pTHX_ bool keep_backslash) {
267 I32 c, nesting;
268 SV *sv;
269 line_t start;
270
271 start = CopLINE(PL_curcop);
272
273 sv = sv_2mortal(newSVpvs(""));
274 if (lex_bufutf8()) {
275 SvUTF8_on(sv);
276 }
277
278 nesting = 0;
279 for (;;) {
280 c = lex_read_unichar(0);
281 if (c == EOF) {
282 CopLINE_set(PL_curcop, start);
283 return NULL;
284 }
285
286 if (c == '\\') {
287 c = lex_read_unichar(0);
288 if (c == EOF) {
289 CopLINE_set(PL_curcop, start);
290 return NULL;
291 }
292 if (keep_backslash || (c != '(' && c != ')')) {
293 sv_catpvs(sv, "\\");
294 }
295 } else if (c == '(') {
296 nesting++;
297 } else if (c == ')') {
298 if (!nesting) {
299 break;
300 }
301 nesting--;
302 }
303
304 my_sv_cat_c(aTHX_ sv, c);
305 }
306
307 return sv;
308}
309
310static void my_check_prototype(pTHX_ const SV *declarator, SV *proto) {
311 char *start, *r, *w, *end;
312 STRLEN len;
313
314 /* strip spaces */
315 start = SvPV(proto, len);
316 end = start + len;
317
318 for (w = r = start; r < end; r++) {
319 if (!isSPACE(*r)) {
320 *w++ = *r;
321 }
322 }
323 *w = '\0';
324 SvCUR_set(proto, w - start);
325 end = w;
326 len = end - start;
327
328 if (!ckWARN(WARN_ILLEGALPROTO)) {
329 return;
330 }
331
332 /* check for bad characters */
333 if (strspn(start, "$@%*;[]&\\_+") != len) {
334 SV *dsv = newSVpvs_flags("", SVs_TEMP);
335 warner(
336 packWARN(WARN_ILLEGALPROTO),
337 "Illegal character in prototype for %"SVf" : %s",
338 SVfARG(declarator),
339 SvUTF8(proto)
340 ? sv_uni_display(
341 dsv,
342 proto,
343 len,
344 UNI_DISPLAY_ISPRINT
345 )
346 : pv_pretty(dsv, start, len, 60, NULL, NULL,
347 PERL_PV_ESCAPE_NONASCII
348 )
349 );
350 return;
351 }
352
353 for (r = start; r < end; r++) {
354 switch (*r) {
355 default:
356 warner(
357 packWARN(WARN_ILLEGALPROTO),
358 "Illegal character in prototype for %"SVf" : %s",
359 SVfARG(declarator), r
360 );
361 return;
362
363 case '_':
364 if (r[1] && !strchr(";@%", *r)) {
365 warner(
366 packWARN(WARN_ILLEGALPROTO),
367 "Illegal character after '_' in prototype for %"SVf" : %s",
368 SVfARG(declarator), r
369 );
370 return;
371 }
372 break;
373
374 case '@':
375 case '%':
376 if (r[1]) {
377 warner(
378 packWARN(WARN_ILLEGALPROTO),
379 "prototype after '%c' for %"SVf": %s",
380 *r, SVfARG(declarator), r + 1
381 );
382 return;
383 }
384 break;
385
386 case '\\':
387 r++;
388 if (strchr("$@%&*", *r)) {
389 break;
390 }
391 if (*r == '[') {
392 r++;
393 for (; r < end && *r != ']'; r++) {
394 if (!strchr("$@%&*", *r)) {
395 break;
396 }
397 }
398 if (*r == ']' && r[-1] != '[') {
399 break;
400 }
401 }
402 warner(
403 packWARN(WARN_ILLEGALPROTO),
404 "Illegal character after '\\' in prototype for %"SVf" : %s",
405 SVfARG(declarator), r
406 );
407 return;
408
409 case '$':
410 case '*':
411 case '&':
412 case ';':
413 case '+':
414 break;
415 }
416 }
417}
418
e158cf8f 419
420DEFSTRUCT(Param) {
421 SV *name;
422 PADOFFSET padoff;
423};
424
425DEFSTRUCT(ParamInit) {
426 Param param;
427 OP *init;
428};
429
430#define VEC(B) B ## _Vec
431
432#define DEFVECTOR(B) DEFSTRUCT(VEC(B)) { \
433 B (*data); \
434 size_t used, size; \
435}
436
437DEFVECTOR(Param);
438DEFVECTOR(ParamInit);
439
440#define DEFVECTOR_INIT(N, B) static void N(VEC(B) *p) { \
441 p->used = 0; \
442 p->size = 23; \
443 Newx(p->data, p->size, B); \
444} static void N(VEC(B) *)
445
446DEFSTRUCT(ParamSpec) {
447 Param invocant;
448 VEC(Param) positional_required;
449 VEC(ParamInit) positional_optional;
450 VEC(Param) named_required;
451 VEC(ParamInit) named_optional;
452 Param slurpy;
453};
454
455DEFVECTOR_INIT(pv_init, Param);
456DEFVECTOR_INIT(piv_init, ParamInit);
457
458static void p_init(Param *p) {
459 p->name = NULL;
460 p->padoff = NOT_IN_PAD;
461}
462
463static void ps_init(ParamSpec *ps) {
464 p_init(&ps->invocant);
465 pv_init(&ps->positional_required);
466 piv_init(&ps->positional_optional);
467 pv_init(&ps->named_required);
468 piv_init(&ps->named_optional);
469 p_init(&ps->slurpy);
470}
471
472#define DEFVECTOR_EXTEND(N, B) static B (*N(VEC(B) *p)) { \
473 assert(p->used <= p->size); \
474 if (p->used == p->size) { \
475 const size_t n = p->size / 2 * 3 + 1; \
476 Renew(p->data, n, B); \
477 p->size = n; \
478 } \
479 return &p->data[p->used]; \
480} static B (*N(VEC(B) *))
481
482DEFVECTOR_EXTEND(pv_extend, Param);
483DEFVECTOR_EXTEND(piv_extend, ParamInit);
484
485#define DEFVECTOR_CLEAR(N, B, F) static void N(pTHX_ VEC(B) *p) { \
486 while (p->used) { \
487 p->used--; \
488 F(aTHX_ &p->data[p->used]); \
489 } \
490 Safefree(p->data); \
491 p->data = NULL; \
492 p->size = 0; \
493} static void N(pTHX_ VEC(B) *)
494
495static void p_clear(pTHX_ Param *p) {
496 p->name = NULL;
497 p->padoff = NOT_IN_PAD;
498}
499
500static void pi_clear(pTHX_ ParamInit *pi) {
501 p_clear(aTHX_ &pi->param);
502 if (pi->init) {
503 op_free(pi->init);
504 pi->init = NULL;
505 }
506}
507
508DEFVECTOR_CLEAR(pv_clear, Param, p_clear);
509DEFVECTOR_CLEAR(piv_clear, ParamInit, pi_clear);
510
511static void ps_clear(pTHX_ ParamSpec *ps) {
512 p_clear(aTHX_ &ps->invocant);
513
514 pv_clear(aTHX_ &ps->positional_required);
515 piv_clear(aTHX_ &ps->positional_optional);
516
517 pv_clear(aTHX_ &ps->named_required);
518 piv_clear(aTHX_ &ps->named_optional);
519
520 p_clear(aTHX_ &ps->slurpy);
521}
522
523static int ps_contains(pTHX_ const ParamSpec *ps, SV *sv) {
524 size_t i, lim;
525
526 if (ps->invocant.name && sv_eq(sv, ps->invocant.name)) {
527 return 1;
528 }
529
530 for (i = 0, lim = ps->positional_required.used; i < lim; i++) {
531 if (sv_eq(sv, ps->positional_required.data[i].name)) {
532 return 1;
533 }
534 }
535
536 for (i = 0, lim = ps->positional_optional.used; i < lim; i++) {
537 if (sv_eq(sv, ps->positional_optional.data[i].param.name)) {
538 return 1;
539 }
540 }
541
542 for (i = 0, lim = ps->named_required.used; i < lim; i++) {
543 if (sv_eq(sv, ps->named_required.data[i].name)) {
544 return 1;
545 }
546 }
547
548 for (i = 0, lim = ps->named_optional.used; i < lim; i++) {
549 if (sv_eq(sv, ps->named_optional.data[i].param.name)) {
550 return 1;
551 }
552 }
553
554 return 0;
555}
556
557static void ps_free_void(pTHX_ void *p) {
558 ps_clear(aTHX_ p);
559 Safefree(p);
560}
561
562static int args_min(pTHX_ const ParamSpec *ps, const KWSpec *ks) {
563 int n = 0;
564 if (!ps) {
565 return SvTRUE(ks->shift) ? 1 : 0;
566 }
567 if (ps->invocant.name) {
568 n++;
569 }
570 n += ps->positional_required.used;
571 n += ps->named_required.used * 2;
572 return n;
573}
574
575static int args_max(const ParamSpec *ps) {
576 int n = 0;
577 if (!ps) {
578 return -1;
579 }
580 if (ps->invocant.name) {
581 n++;
582 }
583 n += ps->positional_required.used;
584 n += ps->positional_optional.used;
585 if (ps->named_required.used || ps->named_optional.used || ps->slurpy.name) {
586 n = -1;
587 }
588 return n;
589}
590
591static size_t count_positional_params(const ParamSpec *ps) {
592 return ps->positional_required.used + ps->positional_optional.used;
593}
594
595static size_t count_named_params(const ParamSpec *ps) {
596 return ps->named_required.used + ps->named_optional.used;
597}
598
599enum {
600 PARAM_INVOCANT = 0x01,
601 PARAM_NAMED = 0x02
602};
603
604/* *pinit must be NULL on entry.
605 * caller must free *pinit on error.
606 */
607static PADOFFSET parse_param(
608 pTHX_
609 const SV *declarator, const KWSpec *spec, ParamSpec *param_spec,
610 int *pflags, SV **pname, OP **pinit
611) {
612 I32 c;
613 char sigil;
614 SV *name;
615
616 assert(!*pinit);
617 *pflags = 0;
618
619 c = lex_peek_unichar(0);
620
621 if (c == ':') {
622 lex_read_unichar(0);
623 lex_read_space(0);
624
625 *pflags |= PARAM_NAMED;
626
627 c = lex_peek_unichar(0);
628 }
629
630 if (c == -1) {
631 croak("In %"SVf": unterminated parameter list", SVfARG(declarator));
632 }
633 if (!(c == '$' || c == '@' || c == '%')) {
634 croak("In %"SVf": unexpected '%c' in parameter list (expecting a sigil)", SVfARG(declarator), (int)c);
635 }
636
637 sigil = c;
638
639 lex_read_unichar(0);
640 lex_read_space(0);
641
642 if (!(name = my_scan_word(aTHX_ FALSE))) {
643 croak("In %"SVf": missing identifier after '%c'", SVfARG(declarator), sigil);
644 }
645 sv_insert(name, 0, 0, &sigil, 1);
646 *pname = name;
647
648 lex_read_space(0);
649 c = lex_peek_unichar(0);
650
651 if (c == '=') {
652 lex_read_unichar(0);
653 lex_read_space(0);
654
655
656 if (!param_spec->invocant.name && SvTRUE(spec->shift)) {
657 param_spec->invocant.name = spec->shift;
658 param_spec->invocant.padoff = pad_add_name_sv(param_spec->invocant.name, 0, NULL, NULL);
659 }
660
661 *pinit = parse_termexpr(0);
662
663 lex_read_space(0);
664 c = lex_peek_unichar(0);
665 }
666
667 if (c == ':') {
668 *pflags |= PARAM_INVOCANT;
669 lex_read_unichar(0);
670 lex_read_space(0);
671 } else if (c == ',') {
672 lex_read_unichar(0);
673 lex_read_space(0);
674 } else if (c != ')') {
675 if (c == -1) {
676 croak("In %"SVf": unterminated parameter list", SVfARG(declarator));
677 }
678 croak("In %"SVf": unexpected '%c' in parameter list (expecting ',')", SVfARG(declarator), (int)c);
679 }
680
681 return pad_add_name_sv(*pname, IF_HAVE_PERL_5_16(padadd_NO_DUP_CHECK, 0), NULL, NULL);
682}
683
684static OP *my_var_g(pTHX_ I32 type, I32 flags, PADOFFSET padoff) {
685 OP *var = newOP(type, flags);
686 var->op_targ = padoff;
687 return var;
688}
689
690static OP *my_var(pTHX_ I32 flags, PADOFFSET padoff) {
691 return my_var_g(aTHX_ OP_PADSV, flags, padoff);
692}
693
694static SV *mkbits1(pTHX_ size_t n) {
695 size_t bytes = n / 8, bits = n % 8;
696 SV *sv = newSV(bytes + !!bits);
697 char *p = SvPVX(sv), *q = p;
698 while (bytes--) {
699 *p++ = '\xff';
700 }
701 if (bits) {
702 *p++ = (1u << bits) - 1;
703 }
704 *p = '\0';
705 SvCUR_set(sv, p - q);
706 SvPOK_on(sv);
707 return sv;
708}
709
710static OP *mkvecbits(pTHX_ PADOFFSET padoff, size_t i) {
711 OP *first, *mid, *last, *vec;
712
713 last = newSVOP(OP_CONST, 0, newSViv(1));
714 first = last;
715
716 mid = newSVOP(OP_CONST, 0, newSViv(i));
717 mid->op_sibling = first;
718 first = mid;
719
720 mid = my_var(aTHX_ 0, padoff);
721 mid->op_sibling = first;
722
723 first = newOP(OP_PUSHMARK, 0);
724
725 vec = newLISTOP(OP_VEC, 0, first, mid);
726 vec->op_targ = pad_alloc(OP_VEC, SVs_PADTMP);
727 ((LISTOP *)vec)->op_last = last;
728 op_null(((LISTOP *)vec)->op_first);
729
730 return vec;
731}
732
733static OP *mkargselem(pTHX_ OP *index) {
734 OP *args = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
735 args->op_flags |= OPf_REF;
736
737 return newBINOP(OP_AELEM, 0, args, index);
738}
739
740static OP *mkargselemv(pTHX_ PADOFFSET v) {
741 return mkargselem(aTHX_ my_var(aTHX_ 0, v));
742}
743
63915d26 744static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const KWSpec *spec) {
e158cf8f 745 ParamSpec *param_spec;
c311cef3 746 SV *declarator;
747 I32 floor_ix;
63915d26 748 int save_ix;
c311cef3 749 SV *saw_name;
1e0f1595 750 OP **prelude_sentinel;
c311cef3 751 SV *proto;
752 OP **attrs_sentinel, *body;
753 unsigned builtin_attrs;
db81d362 754 I32 c;
755
db81d362 756 declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len));
db81d362 757
db81d362 758 lex_read_space(0);
759
c311cef3 760 builtin_attrs = 0;
761
db81d362 762 /* function name */
c311cef3 763 saw_name = NULL;
31534187 764 if ((spec->flags & FLAG_NAME_OK) && (saw_name = my_scan_word(aTHX_ TRUE))) {
c311cef3 765
766 if (PL_parser->expect != XSTATE) {
767 /* bail out early so we don't predeclare $saw_name */
768 croak("In %"SVf": I was expecting a function body, not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_name));
769 }
770
db81d362 771 sv_catpvs(declarator, " ");
c311cef3 772 sv_catsv(declarator, saw_name);
773
774 if (
775 sv_eq_pvs(saw_name, "BEGIN") ||
776 sv_eq_pvs(saw_name, "END") ||
777 sv_eq_pvs(saw_name, "INIT") ||
778 sv_eq_pvs(saw_name, "CHECK") ||
779 sv_eq_pvs(saw_name, "UNITCHECK")
780 ) {
781 builtin_attrs |= MY_ATTR_SPECIAL;
782 }
783
db81d362 784 lex_read_space(0);
63915d26 785 } else if (!(spec->flags & FLAG_ANON_OK)) {
31534187 786 croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - PL_parser->bufptr), PL_parser->bufptr);
db81d362 787 } else {
788 sv_catpvs(declarator, " (anon)");
789 }
790
63915d26 791 /* we're a subroutine declaration */
c311cef3 792 floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON);
793 SAVEFREESV(PL_compcv);
794
63915d26 795 /* create outer block: '{' */
796 save_ix = S_block_start(aTHX_ TRUE);
797
1e0f1595 798 /* initialize synthetic optree */
799 Newx(prelude_sentinel, 1, OP *);
800 *prelude_sentinel = NULL;
801 SAVEDESTRUCTOR_X(free_ptr_op, prelude_sentinel);
802
db81d362 803 /* parameters */
e158cf8f 804 param_spec = NULL;
63915d26 805
db81d362 806 c = lex_peek_unichar(0);
807 if (c == '(') {
e158cf8f 808 OP **init_sentinel;
809
810 Newx(init_sentinel, 1, OP *);
811 *init_sentinel = NULL;
812 SAVEDESTRUCTOR_X(free_ptr_op, init_sentinel);
813
814 Newx(param_spec, 1, ParamSpec);
815 ps_init(param_spec);
816 SAVEDESTRUCTOR_X(ps_free_void, param_spec);
db81d362 817
818 lex_read_unichar(0);
819 lex_read_space(0);
820
e158cf8f 821 while ((c = lex_peek_unichar(0)) != ')') {
822 int flags;
823 SV *name;
824 char sigil;
825 PADOFFSET padoff;
c311cef3 826
e158cf8f 827 padoff = parse_param(aTHX_ declarator, spec, param_spec, &flags, &name, init_sentinel);
c311cef3 828
e158cf8f 829 S_intro_my(aTHX);
63915d26 830
e158cf8f 831 sigil = SvPV_nolen(name)[0];
db81d362 832
e158cf8f 833 /* internal consistency */
834 if (flags & PARAM_NAMED) {
835 if (flags & PARAM_INVOCANT) {
836 croak("In %"SVf": invocant %"SVf" can't be a named parameter", SVfARG(declarator), SVfARG(name));
db81d362 837 }
e158cf8f 838 if (sigil != '$') {
839 croak("In %"SVf": named parameter %"SVf" can't be a%s", SVfARG(declarator), SVfARG(name), sigil == '@' ? "n array" : " hash");
db81d362 840 }
e158cf8f 841 } else if (flags & PARAM_INVOCANT) {
842 if (*init_sentinel) {
843 croak("In %"SVf": invocant %"SVf" can't have a default value", SVfARG(declarator), SVfARG(name));
db81d362 844 }
e158cf8f 845 if (sigil != '$') {
846 croak("In %"SVf": invocant %"SVf" can't be a%s", SVfARG(declarator), SVfARG(name), sigil == '@' ? "n array" : " hash");
847 }
848 } else if (sigil != '$' && *init_sentinel) {
849 croak("In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(name));
850 }
db81d362 851
e158cf8f 852 /* external constraints */
853 if (param_spec->slurpy.name) {
854 croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(param_spec->slurpy.name), SVfARG(name));
855 }
856 if (sigil != '$') {
857 assert(!*init_sentinel);
858 param_spec->slurpy.name = name;
859 param_spec->slurpy.padoff = padoff;
860 continue;
861 }
d8e5d540 862
e158cf8f 863 if (!(flags & PARAM_NAMED) && count_named_params(param_spec)) {
864 croak("In %"SVf": positional parameter %"SVf" can't appear after named parameter %"SVf"", SVfARG(declarator), SVfARG(name), SVfARG((param_spec->named_required.used ? param_spec->named_required.data[0] : param_spec->named_optional.data[0].param).name));
865 }
d8e5d540 866
e158cf8f 867 if (flags & PARAM_INVOCANT) {
868 if (param_spec->invocant.name) {
869 croak("In %"SVf": invalid double invocants %"SVf", %"SVf"", SVfARG(declarator), SVfARG(param_spec->invocant.name), SVfARG(name));
870 }
871 if (count_positional_params(param_spec) || count_named_params(param_spec)) {
872 croak("In %"SVf": invocant %"SVf" must be first in parameter list", SVfARG(declarator), SVfARG(name));
63915d26 873 }
e158cf8f 874 if (!(spec->flags & FLAG_INVOCANT)) {
875 croak("In %"SVf": invocant %"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
876 }
877 param_spec->invocant.name = name;
878 param_spec->invocant.padoff = padoff;
879 continue;
880 }
63915d26 881
e158cf8f 882 if (*init_sentinel && !(spec->flags & FLAG_DEFAULT_ARGS)) {
883 croak("In %"SVf": default argument for %"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
884 }
1e0f1595 885
e158cf8f 886 if (ps_contains(aTHX_ param_spec, name)) {
887 croak("In %"SVf": %"SVf" can't appear twice in the same parameter list", SVfARG(declarator), SVfARG(name));
888 }
1e0f1595 889
e158cf8f 890 if (flags & PARAM_NAMED) {
891 if (!(spec->flags & FLAG_NAMED_PARAMS)) {
892 croak("In %"SVf": named parameter :%"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
1e0f1595 893 }
894
e158cf8f 895 if (*init_sentinel) {
896 ParamInit *pi = piv_extend(&param_spec->named_optional);
897 pi->param.name = name;
898 pi->param.padoff = padoff;
899 pi->init = *init_sentinel;
900 *init_sentinel = NULL;
901 param_spec->named_optional.used++;
902 } else {
903 if (param_spec->positional_optional.used) {
904 croak("In %"SVf": can't combine optional positional (%"SVf") and required named (%"SVf") parameters", SVfARG(declarator), SVfARG(param_spec->positional_optional.data[0].param.name), SVfARG(name));
905 }
d8e5d540 906
e158cf8f 907 Param *p = pv_extend(&param_spec->named_required);
908 p->name = name;
909 p->padoff = padoff;
910 param_spec->named_required.used++;
911 }
912 } else {
913 if (*init_sentinel || param_spec->positional_optional.used) {
914 ParamInit *pi = piv_extend(&param_spec->positional_optional);
915 pi->param.name = name;
916 pi->param.padoff = padoff;
917 pi->init = *init_sentinel;
918 *init_sentinel = NULL;
919 param_spec->positional_optional.used++;
920 } else {
921 Param *p = pv_extend(&param_spec->positional_required);
922 p->name = name;
923 p->padoff = padoff;
924 param_spec->positional_required.used++;
db81d362 925 }
926 }
927
e158cf8f 928 }
929 lex_read_unichar(0);
930 lex_read_space(0);
931 *init_sentinel = NULL;
db81d362 932
e158cf8f 933 if (!param_spec->invocant.name && SvTRUE(spec->shift)) {
934 if (ps_contains(aTHX_ param_spec, spec->shift)) {
935 croak("In %"SVf": %"SVf" can't appear twice in the same parameter list", SVfARG(declarator), SVfARG(spec->shift));
db81d362 936 }
e158cf8f 937
938 param_spec->invocant.name = spec->shift;
939 param_spec->invocant.padoff = pad_add_name_sv(param_spec->invocant.name, 0, NULL, NULL);
db81d362 940 }
941 }
942
943 /* prototype */
c311cef3 944 proto = NULL;
db81d362 945 c = lex_peek_unichar(0);
946 if (c == ':') {
947 lex_read_unichar(0);
948 lex_read_space(0);
949
950 c = lex_peek_unichar(0);
951 if (c != '(') {
c311cef3 952 lex_stuff_pvs(":", 0);
953 c = ':';
db81d362 954 } else {
31534187 955 lex_read_unichar(0);
956 if (!(proto = my_scan_parens_tail(aTHX_ FALSE))) {
f34187b8 957 croak("In %"SVf": prototype not terminated", SVfARG(declarator));
db81d362 958 }
31534187 959 my_check_prototype(aTHX_ declarator, proto);
db81d362 960 lex_read_space(0);
c311cef3 961 c = lex_peek_unichar(0);
db81d362 962 }
963 }
964
db81d362 965 /* attributes */
c311cef3 966 Newx(attrs_sentinel, 1, OP *);
967 *attrs_sentinel = NULL;
311ced6f 968 SAVEDESTRUCTOR_X(free_ptr_op, attrs_sentinel);
c311cef3 969
63915d26 970 if (c == ':' || c == '{') /* '}' - hi, vim */ {
c311cef3 971
972 /* kludge default attributes in */
973 if (SvTRUE(spec->attrs) && SvPV_nolen(spec->attrs)[0] == ':') {
974 lex_stuff_sv(spec->attrs, 0);
975 c = ':';
976 }
b72eb6ee 977
db81d362 978 if (c == ':') {
db81d362 979 lex_read_unichar(0);
980 lex_read_space(0);
db81d362 981 c = lex_peek_unichar(0);
c311cef3 982
983 for (;;) {
984 SV *attr;
985
31534187 986 if (!(attr = my_scan_word(aTHX_ FALSE))) {
c311cef3 987 break;
db81d362 988 }
c311cef3 989
db81d362 990 lex_read_space(0);
991 c = lex_peek_unichar(0);
c311cef3 992
993 if (c != '(') {
994 if (sv_eq_pvs(attr, "lvalue")) {
995 builtin_attrs |= MY_ATTR_LVALUE;
996 attr = NULL;
997 } else if (sv_eq_pvs(attr, "method")) {
998 builtin_attrs |= MY_ATTR_METHOD;
999 attr = NULL;
1000 }
1001 } else {
31534187 1002 SV *sv;
1003 lex_read_unichar(0);
1004 if (!(sv = my_scan_parens_tail(aTHX_ TRUE))) {
c311cef3 1005 croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator));
1006 }
31534187 1007 sv_catpvs(attr, "(");
c311cef3 1008 sv_catsv(attr, sv);
31534187 1009 sv_catpvs(attr, ")");
c311cef3 1010
1011 lex_read_space(0);
1012 c = lex_peek_unichar(0);
1013 }
1014
1015 if (attr) {
1016 *attrs_sentinel = op_append_elem(OP_LIST, *attrs_sentinel, newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(attr)));
1017 }
1018
1019 if (c == ':') {
1020 lex_read_unichar(0);
1021 lex_read_space(0);
1022 c = lex_peek_unichar(0);
1023 }
db81d362 1024 }
1025 }
1026 }
1027
1028 /* body */
63915d26 1029 if (c != '{') /* '}' - hi, vim */ {
85bc3fbd 1030 croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c);
db81d362 1031 }
c311cef3 1032
63915d26 1033 /* surprise predeclaration! */
1034 if (saw_name) {
1035 /* 'sub NAME (PROTO);' to make name/proto known to perl before it
1036 starts parsing the body */
1037 const I32 sub_ix = start_subparse(FALSE, 0);
1038 SAVEFREESV(PL_compcv);
1039
1040 SvREFCNT_inc_simple_void(PL_compcv);
1041
1042 newATTRSUB(
1043 sub_ix,
1044 newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)),
1045 proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
1046 NULL,
1047 NULL
1048 );
1049 }
1050
c311cef3 1051 if (builtin_attrs & MY_ATTR_LVALUE) {
1052 CvLVALUE_on(PL_compcv);
db81d362 1053 }
c311cef3 1054 if (builtin_attrs & MY_ATTR_METHOD) {
1055 CvMETHOD_on(PL_compcv);
1056 }
1057 if (builtin_attrs & MY_ATTR_SPECIAL) {
1058 CvSPECIAL_on(PL_compcv);
db81d362 1059 }
1060
e158cf8f 1061 /* check number of arguments */
1062 if (spec->flags & FLAG_CHECK_NARGS) {
1063 int amin, amax;
1064 size_t named;
d8e5d540 1065
e158cf8f 1066 amin = args_min(aTHX_ param_spec, spec);
1067 if (amin > 0) {
1068 OP *chk, *cond, *err, *croak;
d8e5d540 1069
e158cf8f 1070 err = newSVOP(OP_CONST, 0,
1071 newSVpvf("Not enough arguments for %"SVf" (expected %d, got ", SVfARG(declarator), amin));
1072 err = newBINOP(OP_CONCAT, 0,
1073 err,
1074 newAVREF(newGVOP(OP_GV, 0, PL_defgv)));
1075 err = newBINOP(OP_CONCAT, 0,
1076 err,
1077 newSVOP(OP_CONST, 0, newSVpvs(")")));
d8e5d540 1078
e158cf8f 1079 croak = newCVREF(OPf_WANT_SCALAR,
1080 newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
1081 err = newUNOP(OP_ENTERSUB, OPf_STACKED,
1082 op_append_elem(OP_LIST, err, croak));
d8e5d540 1083
e158cf8f 1084 cond = newBINOP(OP_LT, 0,
1085 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1086 newSVOP(OP_CONST, 0, newSViv(amin)));
1087 chk = newLOGOP(OP_AND, 0, cond, err);
1088
1089 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
1e0f1595 1090 }
abccbe86 1091
e158cf8f 1092 amax = args_max(param_spec);
1093 if (amax >= 0) {
1e0f1595 1094 OP *chk, *cond, *err, *croak;
63915d26 1095
1e0f1595 1096 err = newSVOP(OP_CONST, 0,
e158cf8f 1097 newSVpvf("Too many arguments for %"SVf" (expected %d, got ", SVfARG(declarator), amax));
1098 err = newBINOP(OP_CONCAT, 0,
1099 err,
1100 newAVREF(newGVOP(OP_GV, 0, PL_defgv)));
1101 err = newBINOP(OP_CONCAT, 0,
1102 err,
1103 newSVOP(OP_CONST, 0, newSVpvs(")")));
63915d26 1104
1e0f1595 1105 croak = newCVREF(OPf_WANT_SCALAR,
e158cf8f 1106 newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
1e0f1595 1107 err = newUNOP(OP_ENTERSUB, OPf_STACKED,
e158cf8f 1108 op_append_elem(OP_LIST, err, croak));
63915d26 1109
e158cf8f 1110 cond = newBINOP(OP_GT, 0,
1111 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1112 newSVOP(OP_CONST, 0, newSViv(amax)));
1e0f1595 1113 chk = newLOGOP(OP_AND, 0, cond, err);
63915d26 1114
1e0f1595 1115 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
1116 }
e158cf8f 1117
1118 if (param_spec && (count_named_params(param_spec) || (param_spec->slurpy.name && SvPV_nolen(param_spec->slurpy.name)[0] == '%'))) {
1e0f1595 1119 OP *chk, *cond, *err, *croak;
e158cf8f 1120 const UV fixed = count_positional_params(param_spec) + !!param_spec->invocant.name;
63915d26 1121
1e0f1595 1122 err = newSVOP(OP_CONST, 0,
e158cf8f 1123 newSVpvf("Odd number of paired arguments for %"SVf"", SVfARG(declarator)));
63915d26 1124
1e0f1595 1125 croak = newCVREF(OPf_WANT_SCALAR,
e158cf8f 1126 newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
1e0f1595 1127 err = newUNOP(OP_ENTERSUB, OPf_STACKED,
e158cf8f 1128 op_append_elem(OP_LIST, err, croak));
63915d26 1129
1e0f1595 1130 cond = newBINOP(OP_GT, 0,
e158cf8f 1131 fixed
1132 ? newBINOP(OP_SUBTRACT, 0,
1133 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1134 newSVOP(OP_CONST, 0, newSVuv(fixed)))
1135 : newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1136 newSVOP(OP_CONST, 0, newSViv(0)));
1137 cond = newLOGOP(OP_AND, 0,
1138 cond,
1139 newBINOP(OP_MODULO, 0,
1140 fixed
1141 ? newBINOP(OP_SUBTRACT, 0,
1142 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1143 newSVOP(OP_CONST, 0, newSVuv(fixed)))
1144 : newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1145 newSVOP(OP_CONST, 0, newSViv(2))));
1e0f1595 1146 chk = newLOGOP(OP_AND, 0, cond, err);
63915d26 1147
1e0f1595 1148 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
c311cef3 1149 }
1e0f1595 1150 }
c311cef3 1151
e158cf8f 1152 if (!param_spec) {
1153 /* my $invocant = shift; */
1154 if (SvTRUE(spec->shift)) {
1155 OP *var;
abccbe86 1156
e158cf8f 1157 var = my_var(
1158 aTHX_
1159 OPf_MOD | (OPpLVAL_INTRO << 8),
1160 pad_add_name_sv(spec->shift, 0, NULL, NULL)
1161 );
1162 var = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0));
c311cef3 1163
e158cf8f 1164 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
1165 }
1166 } else {
1167 /* my $invocant = shift; */
1168 if (param_spec->invocant.name) {
1169 OP *var;
c311cef3 1170
e158cf8f 1171 var = my_var(
1172 aTHX_
1173 OPf_MOD | (OPpLVAL_INTRO << 8),
1174 param_spec->invocant.padoff
1175 );
1176 var = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0));
1e0f1595 1177
e158cf8f 1178 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
c311cef3 1179 }
1180
e158cf8f 1181 /* my (...) = @_; */
1182 {
1183 OP *lhs;
1184 size_t i, lim;
63915d26 1185
e158cf8f 1186 lhs = NULL;
63915d26 1187
e158cf8f 1188 for (i = 0, lim = param_spec->positional_required.used; i < lim; i++) {
1189 OP *const var = my_var(
1190 aTHX_
1191 OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
1192 param_spec->positional_required.data[i].padoff
1193 );
1194 lhs = op_append_elem(OP_LIST, lhs, var);
1195 }
63915d26 1196
e158cf8f 1197 for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) {
1198 OP *const var = my_var(
1199 aTHX_
1200 OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
1201 param_spec->positional_optional.data[i].param.padoff
1202 );
1203 lhs = op_append_elem(OP_LIST, lhs, var);
1204 }
63915d26 1205
e158cf8f 1206 if (param_spec->slurpy.name) {
1207 if (count_named_params(param_spec)) {
1208 OP *const var = my_var_g(
1209 aTHX_
1210 SvPV_nolen(param_spec->slurpy.name)[0] == '@' ? OP_PADAV : OP_PADHV,
1211 OPf_MOD | (OPpLVAL_INTRO << 8),
1212 param_spec->slurpy.padoff
1213 );
1214 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
1215 } else {
1216 OP *const var = my_var_g(
1217 aTHX_
1218 SvPV_nolen(param_spec->slurpy.name)[0] == '@' ? OP_PADAV : OP_PADHV,
1219 OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
1220 param_spec->slurpy.padoff
1221 );
1222 lhs = op_append_elem(OP_LIST, lhs, var);
1223 }
1224 }
63915d26 1225
e158cf8f 1226 if (lhs) {
1227 OP *rhs;
1228 lhs->op_flags |= OPf_PARENS;
1229 rhs = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
1230
1231 *prelude_sentinel = op_append_list(
1232 OP_LINESEQ, *prelude_sentinel,
1233 newSTATEOP(
1234 0, NULL,
1235 newASSIGNOP(OPf_STACKED, lhs, 0, rhs)
1236 )
1237 );
1238 }
1239 }
63915d26 1240
e158cf8f 1241 /* default arguments */
1242 {
1243 size_t i, lim, req;
1244 OP *nest;
63915d26 1245
e158cf8f 1246 nest = NULL;
63915d26 1247
e158cf8f 1248 req = param_spec->positional_required.used;
1249 for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) {
1250 ParamInit *cur = &param_spec->positional_optional.data[i];
1251 OP *var, *cond;
63915d26 1252
e158cf8f 1253 cond = newBINOP(
1254 OP_LT, 0,
1255 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1256 newSVOP(OP_CONST, 0, newSViv(req + i + 1))
1257 );
1e0f1595 1258
e158cf8f 1259 var = my_var(aTHX_ 0, cur->param.padoff);
1260
1261 nest = op_append_list(
1262 OP_LINESEQ, nest,
1263 newASSIGNOP(OPf_STACKED, var, 0, cur->init)
1264 );
1265 cur->init = NULL;
1266 nest = newCONDOP(
1267 0,
1268 cond,
1269 nest,
1270 NULL
1271 );
1272 }
1273
1274 *prelude_sentinel = op_append_list(
1275 OP_LINESEQ, *prelude_sentinel,
1276 nest
1277 );
c311cef3 1278 }
1279
e158cf8f 1280 /* named parameters */
1281 if (count_named_params(param_spec)) {
1282 int nameblock_ix;
1283 OP *nameblock;
1284 PADOFFSET vb, vc, vi, vk;
0f875412 1285 int vb_is_str, vc_is_str;
e158cf8f 1286 const size_t pos = count_positional_params(param_spec);
1287
1288 nameblock = NULL;
1289 nameblock_ix = S_block_start(aTHX_ TRUE);
1290
1291 {
1292 OP *decl, *var;
1293
1294 decl = NULL;
1295
0f875412 1296 vb_is_str = param_spec->named_required.used > UV_BITS;
e158cf8f 1297 if (!param_spec->named_required.used || !(spec->flags & FLAG_CHECK_NARGS)) {
1298 vb = 0;
1299 } else {
1300 var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8));
1301 var->op_targ = vb = pad_add_name_pvs("$__B", 0, NULL, NULL);
0f875412 1302 var = newASSIGNOP(OPf_STACKED, var, 0, newSVOP(OP_CONST, 0, vb_is_str ? newSVpvs("") : newSVuv(0)));
e158cf8f 1303 decl = op_append_list(OP_LINESEQ, decl, newSTATEOP(0, NULL, var));
1304 }
1305
0f875412 1306 vc_is_str = param_spec->named_optional.used > UV_BITS;
e158cf8f 1307 if (!param_spec->named_optional.used) {
1308 vc = 0;
1309 } else {
1310 var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8));
1311 var->op_targ = vc = pad_add_name_pvs("$__C", 0, NULL, NULL);
0f875412 1312 var = newASSIGNOP(OPf_STACKED, var, 0, newSVOP(OP_CONST, 0, vc_is_str ? newSVpvs("") : newSVuv(0)));
e158cf8f 1313 decl = op_append_list(OP_LINESEQ, decl, newSTATEOP(0, NULL, var));
1314 }
1315
1316 var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8));
1317 var->op_targ = vk = pad_add_name_pvs("$__K", 0, NULL, NULL);
1318 decl = op_append_list(OP_LINESEQ, decl, newSTATEOP(0, NULL, var));
1319
1320 var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8));
1321 var->op_targ = vi = pad_add_name_pvs("$__I", 0, NULL, NULL);
1322 var = newASSIGNOP(OPf_STACKED, var, 0, newSVOP(OP_CONST, 0, newSViv(pos)));
1323 decl = op_append_list(OP_LINESEQ, decl, newSTATEOP(0, NULL, var));
1324
1325 //S_intro_my(aTHX);
1326 nameblock = op_append_list(OP_LINESEQ, nameblock, decl);
1327 }
1328
1329 {
1330 OP *loop;
1331
1332 loop = NULL;
1333
1334 loop = op_append_list(
1335 OP_LINESEQ,
1336 loop,
1337 newSTATEOP(
1338 0, NULL,
1339 newASSIGNOP(
1340 OPf_STACKED,
1341 my_var(aTHX_ 0, vk),
1342 0,
1343 mkargselemv(aTHX_ vi)
1344 )
1345 )
1346 );
1347
1348 {
1349 OP *nest;
1350 size_t i;
1351
1352 if (param_spec->slurpy.name) {
1353 if (SvPV_nolen(param_spec->slurpy.name)[0] == '@') {
1354 OP *first, *mid, *last;
1355
1356 last = mkargselem(
1357 aTHX_
1358 newBINOP(
1359 OP_ADD, 0,
1360 my_var(aTHX_ 0, vi),
1361 newSVOP(OP_CONST, 0, newSViv(1))
1362 )
1363 );
1364 mid = last;
1365
1366 first = my_var(aTHX_ 0, vk);
1367 first->op_sibling = mid;
1368 mid = first;
1369
1370 first = my_var_g(aTHX_ OP_PADAV, 0, param_spec->slurpy.padoff);
1371 first->op_sibling = mid;
1372 mid = first;
1373
1374 first = newOP(OP_PUSHMARK, 0);
1375 nest = newLISTOP(OP_PUSH, 0, first, mid);
1376 nest->op_targ = pad_alloc(OP_PUSH, SVs_PADTMP);
1377 ((LISTOP *)nest)->op_last = last;
1378 } else {
1379 nest = newASSIGNOP(
1380 OPf_STACKED,
1381 newBINOP(
1382 OP_HELEM, 0,
1383 my_var_g(aTHX_ OP_PADHV, 0, param_spec->slurpy.padoff),
1384 my_var(aTHX_ 0, vk)
1385 ),
1386 0,
1387 mkargselem(
1388 aTHX_
1389 newBINOP(
1390 OP_ADD, 0,
1391 my_var(aTHX_ 0, vi),
1392 newSVOP(OP_CONST, 0, newSViv(1))
1393 )
1394 )
1395 );
1396 }
1397 } else if (spec->flags & FLAG_CHECK_NARGS) {
1398 OP *err, *croak;
1399
1400 err = newSVOP(OP_CONST, 0,
0f875412 1401 newSVpvf("In %"SVf": no such named parameter: ", SVfARG(declarator)));
e158cf8f 1402 err = newBINOP(
1403 OP_CONCAT, 0,
1404 err,
1405 my_var(aTHX_ 0, vk)
1406 );
1407
1408 croak = newCVREF(OPf_WANT_SCALAR,
1409 newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
1410 nest = newUNOP(OP_ENTERSUB, OPf_STACKED,
1411 op_append_elem(OP_LIST, err, croak));
1412 } else {
1413 nest = NULL;
1414 }
1415
1416 for (i = param_spec->named_optional.used; i--; ) {
1417 Param *cur = &param_spec->named_optional.data[i].param;
1418 size_t dn;
1419 char *dp = SvPV(cur->name, dn);
1420 OP *vec;
1421
1422 if (!(spec->flags & FLAG_CHECK_NARGS)) {
1423 vec = NULL;
0f875412 1424 } else if (vc_is_str) {
e158cf8f 1425 vec = newASSIGNOP(
1426 OPf_STACKED,
1427 mkvecbits(aTHX_ vc, i),
1428 0,
1429 newSVOP(OP_CONST, 0, newSViv(1))
1430 );
0f875412 1431 } else {
1432 vec = newASSIGNOP(
1433 OPf_STACKED,
1434 my_var(0, vc),
1435 OP_BIT_OR,
1436 newSVOP(OP_CONST, 0, newSVuv((UV)1 << i))
1437 );
e158cf8f 1438 }
1439
1440 nest = newCONDOP(
1441 0,
1442 newBINOP(
1443 OP_SEQ, 0,
1444 my_var(aTHX_ 0, vk),
1445 newSVOP(OP_CONST, 0, newSVpvn_utf8(dp + 1, dn - 1, SvUTF8(cur->name)))
1446 ),
1447 op_append_list(
1448 OP_LINESEQ,
1449 newASSIGNOP(
1450 OPf_STACKED,
1451 my_var(aTHX_ 0, cur->padoff),
1452 0,
1453 mkargselem(
1454 aTHX_
1455 newBINOP(
1456 OP_ADD, 0,
1457 my_var(aTHX_ 0, vi),
1458 newSVOP(OP_CONST, 0, newSViv(1))
1459 )
1460 )
1461 ),
1462 vec
1463 ),
1464 nest
1465 );
1466 }
1467
1468 for (i = param_spec->named_required.used; i--; ) {
1469 Param *cur = &param_spec->named_required.data[i];
1470 size_t dn;
1471 char *dp = SvPV(cur->name, dn);
1472 OP *vec;
1473
1474 if (!(spec->flags & FLAG_CHECK_NARGS)) {
1475 vec = NULL;
0f875412 1476 } else if (vb_is_str) {
e158cf8f 1477 vec = newASSIGNOP(
1478 OPf_STACKED,
1479 mkvecbits(aTHX_ vb, i),
1480 0,
1481 newSVOP(OP_CONST, 0, newSViv(1))
1482 );
0f875412 1483 } else {
1484 vec = newASSIGNOP(
1485 OPf_STACKED,
1486 my_var(0, vb),
1487 OP_BIT_OR,
1488 newSVOP(OP_CONST, 0, newSVuv((UV)1 << i))
1489 );
e158cf8f 1490 }
1491
1492 nest = newCONDOP(
1493 0,
1494 newBINOP(
1495 OP_SEQ, 0,
1496 my_var(aTHX_ 0, vk),
1497 newSVOP(OP_CONST, 0, newSVpvn_utf8(dp + 1, dn - 1, SvUTF8(cur->name)))
1498 ),
1499 op_append_list(
1500 OP_LINESEQ,
1501 newASSIGNOP(
1502 OPf_STACKED,
1503 my_var(aTHX_ 0, cur->padoff),
1504 0,
1505 mkargselem(
1506 aTHX_
1507 newBINOP(
1508 OP_ADD, 0,
1509 my_var(aTHX_ 0, vi),
1510 newSVOP(OP_CONST, 0, newSViv(1))
1511 )
1512 )
1513 ),
1514 vec
1515 ),
1516 nest
1517 );
1518 }
1519
1520 loop = op_append_elem(OP_LINESEQ, loop, newSTATEOP(0, NULL, nest));
1521 }
1522
1523 loop = newWHILEOP(
1524 0, 1,
1525 NULL,
1526 newBINOP(
1527 OP_LT, 0,
1528 my_var(aTHX_ 0, vi),
1529 newAVREF(newGVOP(OP_GV, 0, PL_defgv))
1530 ),
1531 loop,
1532 newASSIGNOP(
1533 OPf_STACKED,
1534 my_var(aTHX_ 0, vi),
1535 OP_ADD,
1536 newSVOP(OP_CONST, 0, newSViv(2))
1537 ),
1538 0
1539 );
1540
1541 nameblock = op_append_list(OP_LINESEQ, nameblock, newSTATEOP(0, NULL, loop));
1542 }
1543
1544 if (param_spec->named_required.used && (spec->flags & FLAG_CHECK_NARGS)) {
1545 OP *cond, *err, *croak, *join;
1546
1547 {
1548 size_t i, lim;
1549 OP *first, *mid, *last;
1550
1551 last = newNULLLIST();
1552 mid = last;
1553
1554 for (i = param_spec->named_required.used; i--; ) {
1555 OP *cur;
1556 SV *sv = param_spec->named_required.data[i].name;
1557 size_t n;
1558 char *p = SvPV(sv, n);
1559 cur = newCONDOP(
1560 0,
0f875412 1561 vb_is_str
1562 ? mkvecbits(aTHX_ vb, i)
1563 : newBINOP(OP_BIT_AND, 0, my_var(0, vb), newSVOP(OP_CONST, 0, newSVuv((UV)1 << i)))
1564 ,
e158cf8f 1565 newNULLLIST(),
1566 newSVOP(OP_CONST, 0, newSVpvn_utf8(p + 1, n - 1, SvUTF8(sv)))
1567 );
1568 cur->op_sibling = mid;
1569 mid = cur;
1570 }
1571
1572 first = newSVOP(OP_CONST, 0, newSVpvs(", "));
1573 first->op_sibling = mid;
1574 mid = first;
1575
1576 first = newOP(OP_PUSHMARK, 0);
1577
1578 join = newLISTOP(OP_JOIN, 0, first, mid);
1579 join->op_targ = pad_alloc(OP_JOIN, SVs_PADTMP);
1580 ((LISTOP *)join)->op_last = last;
1581 }
1582
1583 err = newSVOP(
1584 OP_CONST, 0,
0f875412 1585 newSVpvf("In %"SVf": missing named parameter(s): ", SVfARG(declarator))
e158cf8f 1586 );
1587 err = newBINOP(OP_CONCAT, 0, err, join);
1588 croak = newCVREF(
1589 OPf_WANT_SCALAR,
1590 newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
1591 );
1592 err = newUNOP(
1593 OP_ENTERSUB,
1594 OPf_STACKED,
1595 op_append_elem(OP_LIST, err, croak)
1596 );
0f875412 1597 if (vb_is_str) {
1598 cond = newBINOP(
1599 OP_SNE, 0,
1600 my_var(aTHX_ 0, vb),
1601 newSVOP(OP_CONST, 0, mkbits1(aTHX_ param_spec->named_required.used))
1602 );
1603 } else {
1604 cond = newBINOP(
1605 OP_NE, 0,
1606 my_var(aTHX_ 0, vb),
1607 newSVOP(
1608 OP_CONST, 0,
1609 newSVuv(
1610 param_spec->named_required.used == UV_BITS
1611 ? ~(UV)0
1612 : ((UV)1 << param_spec->named_required.used) - 1
1613 )
1614 )
1615 );
1616 }
e158cf8f 1617 err = newCONDOP(
1618 0,
1619 cond,
1620 err,
1621 NULL
1622 );
1623
1624 nameblock = op_append_list(OP_LINESEQ, nameblock, err);
1625 }
1626
1627 if (param_spec->named_optional.used) {
1628 size_t i, lim;
1629
1630 for (i = 0, lim = param_spec->named_optional.used; i < lim; i++) {
1631 ParamInit *const cur = &param_spec->named_optional.data[i];
1632 OP *init, *cond;
1633
1634 init = newASSIGNOP(
1635 OPf_STACKED,
1636 my_var(aTHX_ 0, cur->param.padoff),
1637 0,
1638 cur->init
1639 );
1640 cur->init = NULL;
1641
0f875412 1642 cond = newUNOP(
1643 OP_NOT, OPf_SPECIAL,
1644 vc_is_str
1645 ? mkvecbits(aTHX_ vc, i)
1646 : newBINOP(OP_BIT_AND, 0, my_var(0, vc), newSVOP(OP_CONST, 0, newSVuv((UV)1 << i)))
1647 );
e158cf8f 1648
1649 init = newCONDOP(0, cond, init, NULL);
1650
1651 nameblock = op_append_list(OP_LINESEQ, nameblock, newSTATEOP(0, NULL, init));
1652 }
1653 }
1654
1655 nameblock = S_block_end(aTHX_ nameblock_ix, nameblock);
1656 nameblock = op_scope(nameblock);
1657
1658 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, nameblock);
1659 }
1e0f1595 1660 }
c311cef3 1661
1e0f1595 1662 /* finally let perl parse the actual subroutine body */
1663 body = parse_block(0);
c311cef3 1664
1e0f1595 1665 /* add '();' to make function return nothing by default */
1666 /* (otherwise the invisible parameter initialization can "leak" into
1667 the return value: fun ($x) {}->("asdf", 0) == 2) */
1668 if (*prelude_sentinel) {
1669 body = newSTATEOP(0, NULL, body);
db81d362 1670 }
1671
1e0f1595 1672 body = op_append_list(OP_LINESEQ, *prelude_sentinel, body);
1673 *prelude_sentinel = NULL;
1674
c311cef3 1675 /* it's go time. */
1676 {
1677 OP *const attrs = *attrs_sentinel;
1678 *attrs_sentinel = NULL;
1679 SvREFCNT_inc_simple_void(PL_compcv);
1680
63915d26 1681 /* close outer block: '}' */
1682 S_block_end(aTHX_ save_ix, body);
1683
c311cef3 1684 if (!saw_name) {
1685 *pop = newANONATTRSUB(
1686 floor_ix,
1687 proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
1688 attrs,
1689 body
1690 );
1691 return KEYWORD_PLUGIN_EXPR;
1692 }
1693
1694 newATTRSUB(
1695 floor_ix,
1696 newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)),
1697 proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
1698 attrs,
1699 body
1700 );
5efe0e0e 1701 *pop = newOP(OP_NULL, 0);
c311cef3 1702 return KEYWORD_PLUGIN_STMT;
db81d362 1703 }
db81d362 1704}
1705
1706static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
63915d26 1707 KWSpec spec;
db81d362 1708 int ret;
1709
1710 SAVETMPS;
1711
7dd35535 1712 if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) {
1713 ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec);
db81d362 1714 } else {
7dd35535 1715 ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
db81d362 1716 }
1717
1718 FREETMPS;
1719
1720 return ret;
1721}
1722
1723WARNINGS_RESET
1724
1725MODULE = Function::Parameters PACKAGE = Function::Parameters
1726PROTOTYPES: ENABLE
1727
1728BOOT:
1729WARNINGS_ENABLE {
1730 HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
426a4d69 1731 /**/
d8e5d540 1732 newCONSTSUB(stash, "FLAG_NAME_OK", newSViv(FLAG_NAME_OK));
1733 newCONSTSUB(stash, "FLAG_ANON_OK", newSViv(FLAG_ANON_OK));
63915d26 1734 newCONSTSUB(stash, "FLAG_DEFAULT_ARGS", newSViv(FLAG_DEFAULT_ARGS));
d8e5d540 1735 newCONSTSUB(stash, "FLAG_CHECK_NARGS", newSViv(FLAG_CHECK_NARGS));
1736 newCONSTSUB(stash, "FLAG_INVOCANT", newSViv(FLAG_INVOCANT));
e158cf8f 1737 newCONSTSUB(stash, "FLAG_NAMED_PARAMS", newSViv(FLAG_NAMED_PARAMS));
db81d362 1738 newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
d8e5d540 1739 newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_));
1740 newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
1741 newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_));
426a4d69 1742 /**/
db81d362 1743 next_keyword_plugin = PL_keyword_plugin;
1744 PL_keyword_plugin = my_keyword_plugin;
1745} WARNINGS_RESET
Unnamed repository; edit this file to name it for gitweb.