Parameters.xs

   1 /*
   2 Copyright 2012 Lukas Mai.
   3
   4 This program is free software; you can redistribute it and/or modify it
   5 under the terms of either: the GNU General Public License as published
   6 by the Free Software Foundation; or the Artistic License.
   7
   8 See 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) \
  29         /* WARNINGS_ENABLEW(-Wshadow) :-( */ \
  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
  41  #define WARNINGS_ENABLE
  42 #endif
  43
  44
  45 #define PERL_NO_GET_CONTEXT
  46 #include "EXTERN.h"
  47 #include "perl.h"
  48 #include "XSUB.h"
  49
  50 #include <string.h>
  51
  52
  53 WARNINGS_ENABLE
  54
  55
  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
  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
  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
  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
  91 #define UV_BITS (sizeof (UV) * CHAR_BIT)
  92
  93 enum {
  94         FLAG_NAME_OK      = 0x01,
  95         FLAG_ANON_OK      = 0x02,
  96         FLAG_DEFAULT_ARGS = 0x04,
  97         FLAG_CHECK_NARGS  = 0x08,
  98         FLAG_INVOCANT     = 0x10,
  99         FLAG_NAMED_PARAMS = 0x20
 100 };
 101
 102 DEFSTRUCT(KWSpec) {
 103         unsigned flags;
 104         SV *shift;
 105         SV *attrs;
 106 };
 107
 108 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
 109
 110 static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, KWSpec *spec) {
 111         HV *hints;
 112         SV *sv, **psv;
 113         const char *p, *kw_active;
 114         STRLEN kw_active_len;
 115
 116         spec->flags = 0;
 117         spec->shift = sv_2mortal(newSVpvs(""));
 118         spec->attrs = sv_2mortal(newSVpvs(""));
 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         }
 131         for (
 132                 p = kw_active;
 133                 (p = strchr(p, *kw_ptr)) &&
 134                 p < kw_active + kw_active_len - kw_len;
 135                 p++
 136         ) {
 137                 if (
 138                         (p == kw_active || p[-1] == ' ') &&
 139                         p[kw_len] == ' ' &&
 140                         memcmp(kw_ptr, p, kw_len) == 0
 141                 ) {
 142
 143 #define FETCH_HINTK_INTO(NAME, PTR, LEN, X) STMT_START { \
 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         } \
 153 } STMT_END
 154
 155                         FETCH_HINTK_INTO(FLAGS_, kw_ptr, kw_len, psv);
 156                         spec->flags = SvIV(*psv);
 157
 158                         FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv);
 159                         SvSetSV(spec->shift, *psv);
 160
 161                         FETCH_HINTK_INTO(ATTRS_, kw_ptr, kw_len, psv);
 162                         SvSetSV(spec->attrs, *psv);
 163
 164 #undef FETCH_HINTK_INTO
 165                         return TRUE;
 166                 }
 167         }
 168         return FALSE;
 169 }
 170
 171
 172 static void free_ptr_op(pTHX_ void *vp) {
 173         OP **pp = vp;
 174         op_free(*pp);
 175         Safefree(pp);
 176 }
 177
 178 #define sv_eq_pvs(SV, S) my_sv_eq_pvn(aTHX_ SV, "" S "", sizeof (S) - 1)
 179
 180 static int my_sv_eq_pvn(pTHX_ SV *sv, const char *p, STRLEN n) {
 181         STRLEN sv_len;
 182         const char *sv_p = SvPV(sv, sv_len);
 183         return memcmp(sv_p, p, n) == 0;
 184 }
 185
 186
 187 #include "padop_on_crack.c.inc"
 188
 189
 190 enum {
 191         MY_ATTR_LVALUE = 0x01,
 192         MY_ATTR_METHOD = 0x02,
 193         MY_ATTR_SPECIAL = 0x04
 194 };
 195
 196 static 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
 205 static 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
 211 static 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
 217 static 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
 266 static 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
 310 static 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
 419
 420 DEFSTRUCT(Param) {
 421         SV *name;
 422         PADOFFSET padoff;
 423 };
 424
 425 DEFSTRUCT(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
 437 DEFVECTOR(Param);
 438 DEFVECTOR(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
 446 DEFSTRUCT(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         PADOFFSET rest_hash;
 454 };
 455
 456 DEFVECTOR_INIT(pv_init, Param);
 457 DEFVECTOR_INIT(piv_init, ParamInit);
 458
 459 static void p_init(Param *p) {
 460         p->name = NULL;
 461         p->padoff = NOT_IN_PAD;
 462 }
 463
 464 static void ps_init(ParamSpec *ps) {
 465         p_init(&ps->invocant);
 466         pv_init(&ps->positional_required);
 467         piv_init(&ps->positional_optional);
 468         pv_init(&ps->named_required);
 469         piv_init(&ps->named_optional);
 470         p_init(&ps->slurpy);
 471         ps->rest_hash = NOT_IN_PAD;
 472 }
 473
 474 #define DEFVECTOR_EXTEND(N, B) static B (*N(VEC(B) *p)) { \
 475         assert(p->used <= p->size); \
 476         if (p->used == p->size) { \
 477                 const size_t n = p->size / 2 * 3 + 1; \
 478                 Renew(p->data, n, B); \
 479                 p->size = n; \
 480         } \
 481         return &p->data[p->used]; \
 482 } static B (*N(VEC(B) *))
 483
 484 DEFVECTOR_EXTEND(pv_extend, Param);
 485 DEFVECTOR_EXTEND(piv_extend, ParamInit);
 486
 487 #define DEFVECTOR_CLEAR(N, B, F) static void N(pTHX_ VEC(B) *p) { \
 488         while (p->used) { \
 489                 p->used--; \
 490                 F(aTHX_ &p->data[p->used]); \
 491         } \
 492         Safefree(p->data); \
 493         p->data = NULL; \
 494         p->size = 0; \
 495 } static void N(pTHX_ VEC(B) *)
 496
 497 static void p_clear(pTHX_ Param *p) {
 498         p->name = NULL;
 499         p->padoff = NOT_IN_PAD;
 500 }
 501
 502 static void pi_clear(pTHX_ ParamInit *pi) {
 503         p_clear(aTHX_ &pi->param);
 504         if (pi->init) {
 505                 op_free(pi->init);
 506                 pi->init = NULL;
 507         }
 508 }
 509
 510 DEFVECTOR_CLEAR(pv_clear, Param, p_clear);
 511 DEFVECTOR_CLEAR(piv_clear, ParamInit, pi_clear);
 512
 513 static void ps_clear(pTHX_ ParamSpec *ps) {
 514         p_clear(aTHX_ &ps->invocant);
 515
 516         pv_clear(aTHX_ &ps->positional_required);
 517         piv_clear(aTHX_ &ps->positional_optional);
 518
 519         pv_clear(aTHX_ &ps->named_required);
 520         piv_clear(aTHX_ &ps->named_optional);
 521
 522         p_clear(aTHX_ &ps->slurpy);
 523 }
 524
 525 static int ps_contains(pTHX_ const ParamSpec *ps, SV *sv) {
 526         size_t i, lim;
 527
 528         if (ps->invocant.name && sv_eq(sv, ps->invocant.name)) {
 529                 return 1;
 530         }
 531
 532         for (i = 0, lim = ps->positional_required.used; i < lim; i++) {
 533                 if (sv_eq(sv, ps->positional_required.data[i].name)) {
 534                         return 1;
 535                 }
 536         }
 537
 538         for (i = 0, lim = ps->positional_optional.used; i < lim; i++) {
 539                 if (sv_eq(sv, ps->positional_optional.data[i].param.name)) {
 540                         return 1;
 541                 }
 542         }
 543
 544         for (i = 0, lim = ps->named_required.used; i < lim; i++) {
 545                 if (sv_eq(sv, ps->named_required.data[i].name)) {
 546                         return 1;
 547                 }
 548         }
 549
 550         for (i = 0, lim = ps->named_optional.used; i < lim; i++) {
 551                 if (sv_eq(sv, ps->named_optional.data[i].param.name)) {
 552                         return 1;
 553                 }
 554         }
 555
 556         return 0;
 557 }
 558
 559 static void ps_free_void(pTHX_ void *p) {
 560         ps_clear(aTHX_ p);
 561         Safefree(p);
 562 }
 563
 564 static int args_min(pTHX_ const ParamSpec *ps, const KWSpec *ks) {
 565         int n = 0;
 566         if (!ps) {
 567                 return SvTRUE(ks->shift) ? 1 : 0;
 568         }
 569         if (ps->invocant.name) {
 570                 n++;
 571         }
 572         n += ps->positional_required.used;
 573         n += ps->named_required.used * 2;
 574         return n;
 575 }
 576
 577 static int args_max(const ParamSpec *ps) {
 578         int n = 0;
 579         if (!ps) {
 580                 return -1;
 581         }
 582         if (ps->invocant.name) {
 583                 n++;
 584         }
 585         n += ps->positional_required.used;
 586         n += ps->positional_optional.used;
 587         if (ps->named_required.used || ps->named_optional.used || ps->slurpy.name) {
 588                 n = -1;
 589         }
 590         return n;
 591 }
 592
 593 static size_t count_positional_params(const ParamSpec *ps) {
 594         return ps->positional_required.used + ps->positional_optional.used;
 595 }
 596
 597 static size_t count_named_params(const ParamSpec *ps) {
 598         return ps->named_required.used + ps->named_optional.used;
 599 }
 600
 601 enum {
 602         PARAM_INVOCANT = 0x01,
 603         PARAM_NAMED    = 0x02
 604 };
 605
 606 /* *pinit must be NULL on entry.
 607  * caller must free *pinit on error.
 608  */
 609 static PADOFFSET parse_param(
 610         pTHX_
 611         const SV *declarator, const KWSpec *spec, ParamSpec *param_spec,
 612         int *pflags, SV **pname, OP **pinit
 613 ) {
 614         I32 c;
 615         char sigil;
 616         SV *name;
 617
 618         assert(!*pinit);
 619         *pflags = 0;
 620
 621         c = lex_peek_unichar(0);
 622
 623         if (c == ':') {
 624                 lex_read_unichar(0);
 625                 lex_read_space(0);
 626
 627                 *pflags |= PARAM_NAMED;
 628
 629                 c = lex_peek_unichar(0);
 630         }
 631
 632         if (c == -1) {
 633                 croak("In %"SVf": unterminated parameter list", SVfARG(declarator));
 634         }
 635         if (!(c == '$' || c == '@' || c == '%')) {
 636                 croak("In %"SVf": unexpected '%c' in parameter list (expecting a sigil)", SVfARG(declarator), (int)c);
 637         }
 638
 639         sigil = c;
 640
 641         lex_read_unichar(0);
 642         lex_read_space(0);
 643
 644         if (!(name = my_scan_word(aTHX_ FALSE))) {
 645                 croak("In %"SVf": missing identifier after '%c'", SVfARG(declarator), sigil);
 646         }
 647         sv_insert(name, 0, 0, &sigil, 1);
 648         *pname = name;
 649
 650         lex_read_space(0);
 651         c = lex_peek_unichar(0);
 652
 653         if (c == '=') {
 654                 lex_read_unichar(0);
 655                 lex_read_space(0);
 656
 657
 658                 if (!param_spec->invocant.name && SvTRUE(spec->shift)) {
 659                         param_spec->invocant.name = spec->shift;
 660                         param_spec->invocant.padoff = pad_add_name_sv(param_spec->invocant.name, 0, NULL, NULL);
 661                 }
 662
 663                 *pinit = parse_termexpr(0);
 664
 665                 lex_read_space(0);
 666                 c = lex_peek_unichar(0);
 667         }
 668
 669         if (c == ':') {
 670                 *pflags |= PARAM_INVOCANT;
 671                 lex_read_unichar(0);
 672                 lex_read_space(0);
 673         } else if (c == ',') {
 674                 lex_read_unichar(0);
 675                 lex_read_space(0);
 676         } else if (c != ')') {
 677                 if (c == -1) {
 678                         croak("In %"SVf": unterminated parameter list", SVfARG(declarator));
 679                 }
 680                 croak("In %"SVf": unexpected '%c' in parameter list (expecting ',')", SVfARG(declarator), (int)c);
 681         }
 682
 683         return pad_add_name_sv(*pname, IF_HAVE_PERL_5_16(padadd_NO_DUP_CHECK, 0), NULL, NULL);
 684 }
 685
 686 static OP *my_var_g(pTHX_ I32 type, I32 flags, PADOFFSET padoff) {
 687         OP *var = newOP(type, flags);
 688         var->op_targ = padoff;
 689         return var;
 690 }
 691
 692 static OP *my_var(pTHX_ I32 flags, PADOFFSET padoff) {
 693         return my_var_g(aTHX_ OP_PADSV, flags, padoff);
 694 }
 695
 696 static OP *mkhvelem(pTHX_ PADOFFSET h, OP *k) {
 697         OP *hv = my_var_g(aTHX_ OP_PADHV, OPf_REF, h);
 698         return newBINOP(OP_HELEM, 0, hv, k);
 699 }
 700
 701 static OP *mkconstsv(pTHX_ SV *sv) {
 702         return newSVOP(OP_CONST, 0, sv);
 703 }
 704
 705 static OP *mkconstiv(pTHX_ IV i) {
 706         return mkconstsv(aTHX_ newSViv(i));
 707 }
 708
 709 static OP *mkconstpv(pTHX_ const char *p, size_t n) {
 710         return mkconstsv(aTHX_ newSVpv(p, n));
 711 }
 712
 713 #define mkconstpvs(S) mkconstpv(aTHX_ "" S "", sizeof S - 1)
 714
 715 static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const KWSpec *spec) {
 716         ParamSpec *param_spec;
 717         SV *declarator;
 718         I32 floor_ix;
 719         int save_ix;
 720         SV *saw_name;
 721         OP **prelude_sentinel;
 722         SV *proto;
 723         OP **attrs_sentinel, *body;
 724         unsigned builtin_attrs;
 725         I32 c;
 726
 727         declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len));
 728
 729         lex_read_space(0);
 730
 731         builtin_attrs = 0;
 732
 733         /* function name */
 734         saw_name = NULL;
 735         if ((spec->flags & FLAG_NAME_OK) && (saw_name = my_scan_word(aTHX_ TRUE))) {
 736
 737                 if (PL_parser->expect != XSTATE) {
 738                         /* bail out early so we don't predeclare $saw_name */
 739                         croak("In %"SVf": I was expecting a function body, not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_name));
 740                 }
 741
 742                 sv_catpvs(declarator, " ");
 743                 sv_catsv(declarator, saw_name);
 744
 745                 if (
 746                         sv_eq_pvs(saw_name, "BEGIN") ||
 747                         sv_eq_pvs(saw_name, "END") ||
 748                         sv_eq_pvs(saw_name, "INIT") ||
 749                         sv_eq_pvs(saw_name, "CHECK") ||
 750                         sv_eq_pvs(saw_name, "UNITCHECK")
 751                 ) {
 752                         builtin_attrs |= MY_ATTR_SPECIAL;
 753                 }
 754
 755                 lex_read_space(0);
 756         } else if (!(spec->flags & FLAG_ANON_OK)) {
 757                 croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - PL_parser->bufptr), PL_parser->bufptr);
 758         } else {
 759                 sv_catpvs(declarator, " (anon)");
 760         }
 761
 762         /* we're a subroutine declaration */
 763         floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON);
 764         SAVEFREESV(PL_compcv);
 765
 766         /* create outer block: '{' */
 767         save_ix = S_block_start(aTHX_ TRUE);
 768
 769         /* initialize synthetic optree */
 770         Newx(prelude_sentinel, 1, OP *);
 771         *prelude_sentinel = NULL;
 772         SAVEDESTRUCTOR_X(free_ptr_op, prelude_sentinel);
 773
 774         /* parameters */
 775         param_spec = NULL;
 776
 777         c = lex_peek_unichar(0);
 778         if (c == '(') {
 779                 OP **init_sentinel;
 780
 781                 Newx(init_sentinel, 1, OP *);
 782                 *init_sentinel = NULL;
 783                 SAVEDESTRUCTOR_X(free_ptr_op, init_sentinel);
 784
 785                 Newx(param_spec, 1, ParamSpec);
 786                 ps_init(param_spec);
 787                 SAVEDESTRUCTOR_X(ps_free_void, param_spec);
 788
 789                 lex_read_unichar(0);
 790                 lex_read_space(0);
 791
 792                 while ((c = lex_peek_unichar(0)) != ')') {
 793                         int flags;
 794                         SV *name;
 795                         char sigil;
 796                         PADOFFSET padoff;
 797
 798                         padoff = parse_param(aTHX_ declarator, spec, param_spec, &flags, &name, init_sentinel);
 799
 800                         S_intro_my(aTHX);
 801
 802                         sigil = SvPV_nolen(name)[0];
 803
 804                         /* internal consistency */
 805                         if (flags & PARAM_NAMED) {
 806                                 if (flags & PARAM_INVOCANT) {
 807                                         croak("In %"SVf": invocant %"SVf" can't be a named parameter", SVfARG(declarator), SVfARG(name));
 808                                 }
 809                                 if (sigil != '$') {
 810                                         croak("In %"SVf": named parameter %"SVf" can't be a%s", SVfARG(declarator), SVfARG(name), sigil == '@' ? "n array" : " hash");
 811                                 }
 812                         } else if (flags & PARAM_INVOCANT) {
 813                                 if (*init_sentinel) {
 814                                         croak("In %"SVf": invocant %"SVf" can't have a default value", SVfARG(declarator), SVfARG(name));
 815                                 }
 816                                 if (sigil != '$') {
 817                                         croak("In %"SVf": invocant %"SVf" can't be a%s", SVfARG(declarator), SVfARG(name), sigil == '@' ? "n array" : " hash");
 818                                 }
 819                         } else if (sigil != '$' && *init_sentinel) {
 820                                 croak("In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(name));
 821                         }
 822
 823                         /* external constraints */
 824                         if (param_spec->slurpy.name) {
 825                                 croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(param_spec->slurpy.name), SVfARG(name));
 826                         }
 827                         if (sigil != '$') {
 828                                 assert(!*init_sentinel);
 829                                 param_spec->slurpy.name = name;
 830                                 param_spec->slurpy.padoff = padoff;
 831                                 continue;
 832                         }
 833
 834                         if (!(flags & PARAM_NAMED) && count_named_params(param_spec)) {
 835                                 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));
 836                         }
 837
 838                         if (flags & PARAM_INVOCANT) {
 839                                 if (param_spec->invocant.name) {
 840                                         croak("In %"SVf": invalid double invocants %"SVf", %"SVf"", SVfARG(declarator), SVfARG(param_spec->invocant.name), SVfARG(name));
 841                                 }
 842                                 if (count_positional_params(param_spec) || count_named_params(param_spec)) {
 843                                         croak("In %"SVf": invocant %"SVf" must be first in parameter list", SVfARG(declarator), SVfARG(name));
 844                                 }
 845                                 if (!(spec->flags & FLAG_INVOCANT)) {
 846                                         croak("In %"SVf": invocant %"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
 847                                 }
 848                                 param_spec->invocant.name = name;
 849                                 param_spec->invocant.padoff = padoff;
 850                                 continue;
 851                         }
 852
 853                         if (*init_sentinel && !(spec->flags & FLAG_DEFAULT_ARGS)) {
 854                                 croak("In %"SVf": default argument for %"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
 855                         }
 856
 857                         if (ps_contains(aTHX_ param_spec, name)) {
 858                                 croak("In %"SVf": %"SVf" can't appear twice in the same parameter list", SVfARG(declarator), SVfARG(name));
 859                         }
 860
 861                         if (flags & PARAM_NAMED) {
 862                                 if (!(spec->flags & FLAG_NAMED_PARAMS)) {
 863                                         croak("In %"SVf": named parameter :%"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
 864                                 }
 865
 866                                 if (*init_sentinel) {
 867                                         ParamInit *pi = piv_extend(&param_spec->named_optional);
 868                                         pi->param.name = name;
 869                                         pi->param.padoff = padoff;
 870                                         pi->init = *init_sentinel;
 871                                         *init_sentinel = NULL;
 872                                         param_spec->named_optional.used++;
 873                                 } else {
 874                                         if (param_spec->positional_optional.used) {
 875                                                 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));
 876                                         }
 877
 878                                         Param *p = pv_extend(&param_spec->named_required);
 879                                         p->name = name;
 880                                         p->padoff = padoff;
 881                                         param_spec->named_required.used++;
 882                                 }
 883                         } else {
 884                                 if (*init_sentinel || param_spec->positional_optional.used) {
 885                                         ParamInit *pi = piv_extend(&param_spec->positional_optional);
 886                                         pi->param.name = name;
 887                                         pi->param.padoff = padoff;
 888                                         pi->init = *init_sentinel;
 889                                         *init_sentinel = NULL;
 890                                         param_spec->positional_optional.used++;
 891                                 } else {
 892                                         Param *p = pv_extend(&param_spec->positional_required);
 893                                         p->name = name;
 894                                         p->padoff = padoff;
 895                                         param_spec->positional_required.used++;
 896                                 }
 897                         }
 898
 899                 }
 900                 lex_read_unichar(0);
 901                 lex_read_space(0);
 902                 *init_sentinel = NULL;
 903
 904                 if (!param_spec->invocant.name && SvTRUE(spec->shift)) {
 905                         if (ps_contains(aTHX_ param_spec, spec->shift)) {
 906                                 croak("In %"SVf": %"SVf" can't appear twice in the same parameter list", SVfARG(declarator), SVfARG(spec->shift));
 907                         }
 908
 909                         param_spec->invocant.name = spec->shift;
 910                         param_spec->invocant.padoff = pad_add_name_sv(param_spec->invocant.name, 0, NULL, NULL);
 911                 }
 912         }
 913
 914         /* prototype */
 915         proto = NULL;
 916         c = lex_peek_unichar(0);
 917         if (c == ':') {
 918                 lex_read_unichar(0);
 919                 lex_read_space(0);
 920
 921                 c = lex_peek_unichar(0);
 922                 if (c != '(') {
 923                         lex_stuff_pvs(":", 0);
 924                         c = ':';
 925                 } else {
 926                         lex_read_unichar(0);
 927                         if (!(proto = my_scan_parens_tail(aTHX_ FALSE))) {
 928                                 croak("In %"SVf": prototype not terminated", SVfARG(declarator));
 929                         }
 930                         my_check_prototype(aTHX_ declarator, proto);
 931                         lex_read_space(0);
 932                         c = lex_peek_unichar(0);
 933                 }
 934         }
 935
 936         /* attributes */
 937         Newx(attrs_sentinel, 1, OP *);
 938         *attrs_sentinel = NULL;
 939         SAVEDESTRUCTOR_X(free_ptr_op, attrs_sentinel);
 940
 941         if (c == ':' || c == '{') /* '}' - hi, vim */ {
 942
 943                 /* kludge default attributes in */
 944                 if (SvTRUE(spec->attrs) && SvPV_nolen(spec->attrs)[0] == ':') {
 945                         lex_stuff_sv(spec->attrs, 0);
 946                         c = ':';
 947                 }
 948
 949                 if (c == ':') {
 950                         lex_read_unichar(0);
 951                         lex_read_space(0);
 952                         c = lex_peek_unichar(0);
 953
 954                         for (;;) {
 955                                 SV *attr;
 956
 957                                 if (!(attr = my_scan_word(aTHX_ FALSE))) {
 958                                         break;
 959                                 }
 960
 961                                 lex_read_space(0);
 962                                 c = lex_peek_unichar(0);
 963
 964                                 if (c != '(') {
 965                                         if (sv_eq_pvs(attr, "lvalue")) {
 966                                                 builtin_attrs |= MY_ATTR_LVALUE;
 967                                                 attr = NULL;
 968                                         } else if (sv_eq_pvs(attr, "method")) {
 969                                                 builtin_attrs |= MY_ATTR_METHOD;
 970                                                 attr = NULL;
 971                                         }
 972                                 } else {
 973                                         SV *sv;
 974                                         lex_read_unichar(0);
 975                                         if (!(sv = my_scan_parens_tail(aTHX_ TRUE))) {
 976                                                 croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator));
 977                                         }
 978                                         sv_catpvs(attr, "(");
 979                                         sv_catsv(attr, sv);
 980                                         sv_catpvs(attr, ")");
 981
 982                                         lex_read_space(0);
 983                                         c = lex_peek_unichar(0);
 984                                 }
 985
 986                                 if (attr) {
 987                                         *attrs_sentinel = op_append_elem(OP_LIST, *attrs_sentinel, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(attr)));
 988                                 }
 989
 990                                 if (c == ':') {
 991                                         lex_read_unichar(0);
 992                                         lex_read_space(0);
 993                                         c = lex_peek_unichar(0);
 994                                 }
 995                         }
 996                 }
 997         }
 998
 999         /* body */
1000         if (c != '{') /* '}' - hi, vim */ {
1001                 croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c);
1002         }
1003
1004         /* surprise predeclaration! */
1005         if (saw_name) {
1006                 /* 'sub NAME (PROTO);' to make name/proto known to perl before it
1007                    starts parsing the body */
1008                 const I32 sub_ix = start_subparse(FALSE, 0);
1009                 SAVEFREESV(PL_compcv);
1010
1011                 SvREFCNT_inc_simple_void(PL_compcv);
1012
1013                 newATTRSUB(
1014                         sub_ix,
1015                         mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(saw_name)),
1016                         proto ? mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(proto)) : NULL,
1017                         NULL,
1018                         NULL
1019                 );
1020         }
1021
1022         if (builtin_attrs & MY_ATTR_LVALUE) {
1023                 CvLVALUE_on(PL_compcv);
1024         }
1025         if (builtin_attrs & MY_ATTR_METHOD) {
1026                 CvMETHOD_on(PL_compcv);
1027         }
1028         if (builtin_attrs & MY_ATTR_SPECIAL) {
1029                 CvSPECIAL_on(PL_compcv);
1030         }
1031
1032         /* check number of arguments */
1033         if (spec->flags & FLAG_CHECK_NARGS) {
1034                 int amin, amax;
1035                 size_t named;
1036
1037                 amin = args_min(aTHX_ param_spec, spec);
1038                 if (amin > 0) {
1039                         OP *chk, *cond, *err, *croak;
1040
1041                         err = mkconstsv(aTHX_ newSVpvf("Not enough arguments for %"SVf" (expected %d, got ", SVfARG(declarator), amin));
1042                         err = newBINOP(
1043                                 OP_CONCAT, 0,
1044                                 err,
1045                                 newAVREF(newGVOP(OP_GV, 0, PL_defgv))
1046                         );
1047                         err = newBINOP(
1048                                 OP_CONCAT, 0,
1049                                 err,
1050                                 mkconstpvs(")")
1051                         );
1052
1053                         croak = newCVREF(OPf_WANT_SCALAR,
1054                                          newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
1055                         err = newUNOP(OP_ENTERSUB, OPf_STACKED,
1056                                       op_append_elem(OP_LIST, err, croak));
1057
1058                         cond = newBINOP(OP_LT, 0,
1059                                         newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1060                                         mkconstiv(aTHX_ amin));
1061                         chk = newLOGOP(OP_AND, 0, cond, err);
1062
1063                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
1064                 }
1065
1066                 amax = args_max(param_spec);
1067                 if (amax >= 0) {
1068                         OP *chk, *cond, *err, *croak;
1069
1070                         err = mkconstsv(aTHX_ newSVpvf("Too many arguments for %"SVf" (expected %d, got ", SVfARG(declarator), amax));
1071                         err = newBINOP(
1072                                 OP_CONCAT, 0,
1073                                 err,
1074                                 newAVREF(newGVOP(OP_GV, 0, PL_defgv))
1075                         );
1076                         err = newBINOP(
1077                                 OP_CONCAT, 0,
1078                                 err,
1079                                 mkconstpvs(")")
1080                         );
1081
1082                         croak = newCVREF(
1083                                 OPf_WANT_SCALAR,
1084                                 newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
1085                         );
1086                         err = newUNOP(OP_ENTERSUB, OPf_STACKED,
1087                         op_append_elem(OP_LIST, err, croak));
1088
1089                         cond = newBINOP(
1090                                 OP_GT, 0,
1091                                 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1092                                 mkconstiv(aTHX_ amax)
1093                         );
1094                         chk = newLOGOP(OP_AND, 0, cond, err);
1095
1096                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
1097                 }
1098
1099                 if (param_spec && (count_named_params(param_spec) || (param_spec->slurpy.name && SvPV_nolen(param_spec->slurpy.name)[0] == '%'))) {
1100                         OP *chk, *cond, *err, *croak;
1101                         const UV fixed = count_positional_params(param_spec) + !!param_spec->invocant.name;
1102
1103                         err = mkconstsv(aTHX_ newSVpvf("Odd number of paired arguments for %"SVf"", SVfARG(declarator)));
1104
1105                         croak = newCVREF(
1106                                 OPf_WANT_SCALAR,
1107                                 newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
1108                         );
1109                         err = newUNOP(OP_ENTERSUB, OPf_STACKED,
1110                         op_append_elem(OP_LIST, err, croak));
1111
1112                         cond = newBINOP(OP_GT, 0,
1113                                         newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1114                                         mkconstiv(aTHX_ fixed));
1115                         cond = newLOGOP(OP_AND, 0,
1116                                         cond,
1117                                         newBINOP(OP_MODULO, 0,
1118                                                  fixed
1119                                                  ? newBINOP(OP_SUBTRACT, 0,
1120                                                             newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1121                                                             mkconstiv(aTHX_ fixed))
1122                                                  : newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1123                                                  mkconstiv(aTHX_ 2)));
1124                         chk = newLOGOP(OP_AND, 0, cond, err);
1125
1126                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
1127                 }
1128         }
1129
1130         if (!param_spec) {
1131                 /* my $invocant = shift; */
1132                 if (SvTRUE(spec->shift)) {
1133                         OP *var;
1134
1135                         var = my_var(
1136                                 aTHX_
1137                                 OPf_MOD | (OPpLVAL_INTRO << 8),
1138                                 pad_add_name_sv(spec->shift, 0, NULL, NULL)
1139                         );
1140                         var = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0));
1141
1142                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
1143                 }
1144         } else {
1145                 /* my $invocant = shift; */
1146                 if (param_spec->invocant.name) {
1147                         OP *var;
1148
1149                         var = my_var(
1150                                 aTHX_
1151                                 OPf_MOD | (OPpLVAL_INTRO << 8),
1152                                 param_spec->invocant.padoff
1153                         );
1154                         var = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0));
1155
1156                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
1157                 }
1158
1159                 /* my (...) = @_; */
1160                 {
1161                         OP *lhs;
1162                         size_t i, lim;
1163
1164                         lhs = NULL;
1165
1166                         for (i = 0, lim = param_spec->positional_required.used; i < lim; i++) {
1167                                 OP *const var = my_var(
1168                                         aTHX_
1169                                         OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
1170                                         param_spec->positional_required.data[i].padoff
1171                                 );
1172                                 lhs = op_append_elem(OP_LIST, lhs, var);
1173                         }
1174
1175                         for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) {
1176                                 OP *const var = my_var(
1177                                         aTHX_
1178                                         OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
1179                                         param_spec->positional_optional.data[i].param.padoff
1180                                 );
1181                                 lhs = op_append_elem(OP_LIST, lhs, var);
1182                         }
1183
1184                         {
1185                                 PADOFFSET padoff;
1186                                 I32 type;
1187                                 bool slurpy_hash;
1188
1189                                 /*
1190                                  * cases:
1191                                  *  1) no named params
1192                                  *   1.1) slurpy
1193                                  *       => put it in
1194                                  *   1.2) no slurpy
1195                                  *       => nop
1196                                  *  2) named params
1197                                  *   2.1) no slurpy
1198                                  *       => synthetic %{rest}
1199                                  *   2.2) slurpy is a hash
1200                                  *       => put it in
1201                                  *   2.3) slurpy is an array
1202                                  *       => synthetic %{rest}
1203                                  *          remember to declare array later
1204                                  */
1205
1206                                 slurpy_hash = param_spec->slurpy.name && SvPV_nolen(param_spec->slurpy.name)[0] == '%';
1207                                 if (!count_named_params(param_spec)) {
1208                                         if (param_spec->slurpy.name) {
1209                                                 padoff = param_spec->slurpy.padoff;
1210                                                 type = slurpy_hash ? OP_PADHV : OP_PADAV;
1211                                         } else {
1212                                                 padoff = NOT_IN_PAD;
1213                                                 type = OP_PADSV;
1214                                         }
1215                                 } else if (slurpy_hash) {
1216                                         padoff = param_spec->slurpy.padoff;
1217                                         type = OP_PADHV;
1218                                 } else {
1219                                         padoff = param_spec->rest_hash = pad_add_name_pvs("%{rest}", 0, NULL, NULL);
1220                                         type = OP_PADHV;
1221                                 }
1222
1223                                 if (padoff != NOT_IN_PAD) {
1224                                         OP *const var = my_var_g(
1225                                                 aTHX_
1226                                                 type,
1227                                                 OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
1228                                                 padoff
1229                                         );
1230
1231                                         lhs = op_append_elem(OP_LIST, lhs, var);
1232
1233                                         if (type == OP_PADHV) {
1234                                                 param_spec->rest_hash = padoff;
1235                                         }
1236                                 }
1237                         }
1238
1239                         if (lhs) {
1240                                 OP *rhs;
1241                                 lhs->op_flags |= OPf_PARENS;
1242                                 rhs = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
1243
1244                                 *prelude_sentinel = op_append_list(
1245                                         OP_LINESEQ, *prelude_sentinel,
1246                                         newSTATEOP(
1247                                                 0, NULL,
1248                                                 newASSIGNOP(OPf_STACKED, lhs, 0, rhs)
1249                                         )
1250                                 );
1251                         }
1252                 }
1253
1254                 /* default positional arguments */
1255                 {
1256                         size_t i, lim, req;
1257                         OP *nest;
1258
1259                         nest = NULL;
1260
1261                         req = param_spec->positional_required.used;
1262                         for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) {
1263                                 ParamInit *cur = &param_spec->positional_optional.data[i];
1264                                 OP *var, *cond;
1265
1266                                 cond = newBINOP(
1267                                         OP_LT, 0,
1268                                         newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1269                                         mkconstiv(aTHX_ req + i + 1)
1270                                 );
1271
1272                                 var = my_var(aTHX_ 0, cur->param.padoff);
1273
1274                                 nest = op_append_list(
1275                                         OP_LINESEQ, nest,
1276                                         newASSIGNOP(OPf_STACKED, var, 0, cur->init)
1277                                 );
1278                                 cur->init = NULL;
1279                                 nest = newCONDOP(
1280                                         0,
1281                                         cond,
1282                                         nest,
1283                                         NULL
1284                                 );
1285                         }
1286
1287                         *prelude_sentinel = op_append_list(
1288                                 OP_LINESEQ, *prelude_sentinel,
1289                                 nest
1290                         );
1291                 }
1292
1293                 /* named parameters */
1294                 if (count_named_params(param_spec)) {
1295                         size_t i, lim;
1296
1297                         assert(param_spec->rest_hash != NOT_IN_PAD);
1298
1299                         for (i = 0, lim = param_spec->named_required.used; i < lim; i++) {
1300                                 Param *cur = &param_spec->named_required.data[i];
1301                                 size_t n;
1302                                 char *p = SvPV(cur->name, n);
1303                                 OP *var, *cond;
1304
1305                                 cond = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1));
1306
1307                                 if (spec->flags & FLAG_CHECK_NARGS) {
1308                                         OP *croak, *msg;
1309
1310                                         var = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1));
1311                                         var = newUNOP(OP_DELETE, 0, var);
1312
1313                                         msg = mkconstsv(aTHX_ newSVpvf("In %"SVf": missing named parameter: %.*s", SVfARG(declarator), (int)(n - 1), p + 1));
1314                                         croak = newCVREF(
1315                                                 OPf_WANT_SCALAR,
1316                                                 newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
1317                                         );
1318                                         croak = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, msg, croak));
1319
1320                                         cond = newUNOP(OP_EXISTS, 0, cond);
1321
1322                                         cond = newCONDOP(0, cond, var, croak);
1323                                 }
1324
1325                                 var = my_var(
1326                                         aTHX_
1327                                         OPf_MOD | (OPpLVAL_INTRO << 8),
1328                                         cur->padoff
1329                                 );
1330                                 var = newASSIGNOP(OPf_STACKED, var, 0, cond);
1331
1332                                 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
1333                         }
1334
1335                         for (i = 0, lim = param_spec->named_optional.used; i < lim; i++) {
1336                                 ParamInit *cur = &param_spec->named_optional.data[i];
1337                                 size_t n;
1338                                 char *p = SvPV(cur->param.name, n);
1339                                 OP *var, *cond;
1340
1341                                 var = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1));
1342                                 var = newUNOP(OP_DELETE, 0, var);
1343
1344                                 cond = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1));
1345                                 cond = newUNOP(OP_EXISTS, 0, cond);
1346
1347                                 cond = newCONDOP(0, cond, var, cur->init);
1348                                 cur->init = NULL;
1349
1350                                 var = my_var(
1351                                         aTHX_
1352                                         OPf_MOD | (OPpLVAL_INTRO << 8),
1353                                         cur->param.padoff
1354                                 );
1355                                 var = newASSIGNOP(OPf_STACKED, var, 0, cond);
1356
1357                                 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
1358                         }
1359
1360                         if (!param_spec->slurpy.name) {
1361                                 if (spec->flags & FLAG_CHECK_NARGS) {
1362                                         /* croak if %{rest} */
1363                                         OP *croak, *cond, *keys, *msg;
1364
1365                                         keys = newUNOP(OP_KEYS, 0, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash));
1366                                         keys = newLISTOP(OP_SORT, 0, newOP(OP_PUSHMARK, 0), keys);
1367                                         {
1368                                                 OP *first, *mid, *last;
1369
1370                                                 last = keys;
1371
1372                                                 mid = mkconstpvs(", ");
1373                                                 mid->op_sibling = last;
1374
1375                                                 first = newOP(OP_PUSHMARK, 0);
1376
1377                                                 keys = newLISTOP(OP_JOIN, 0, first, mid);
1378                                                 keys->op_targ = pad_alloc(OP_JOIN, SVs_PADTMP);
1379                                                 ((LISTOP *)keys)->op_last = last;
1380                                         }
1381
1382                                         msg = mkconstsv(aTHX_ newSVpvf("In %"SVf": no such named parameter: ", SVfARG(declarator)));
1383                                         msg = newBINOP(OP_CONCAT, 0, msg, keys);
1384
1385                                         croak = newCVREF(
1386                                                 OPf_WANT_SCALAR,
1387                                                 newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
1388                                         );
1389                                         croak = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, msg, croak));
1390
1391                                         cond = newUNOP(OP_KEYS, 0, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash));
1392                                         croak = newCONDOP(0, cond, croak, NULL);
1393
1394                                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, croak));
1395                                 } else {
1396                                         OP *clear;
1397
1398                                         clear = newASSIGNOP(
1399                                                 OPf_STACKED,
1400                                                 my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash),
1401                                                 0,
1402                                                 newNULLLIST()
1403                                         );
1404
1405                                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, clear));
1406                                 }
1407                         } else if (param_spec->slurpy.padoff != param_spec->rest_hash) {
1408                                 OP *var, *clear;
1409
1410                                 assert(SvPV_nolen(param_spec->slurpy.name)[0] == '@');
1411
1412                                 var = my_var_g(
1413                                         aTHX_
1414                                         OP_PADAV,
1415                                         OPf_MOD | (OPpLVAL_INTRO << 8),
1416                                         param_spec->slurpy.padoff
1417                                 );
1418
1419                                 var = newASSIGNOP(OPf_STACKED, var, 0, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash));
1420
1421                                 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
1422
1423                                 clear = newASSIGNOP(
1424                                         OPf_STACKED,
1425                                         my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash),
1426                                         0,
1427                                         newNULLLIST()
1428                                 );
1429
1430                                 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, clear));
1431                         }
1432                 }
1433         }
1434
1435         /* finally let perl parse the actual subroutine body */
1436         body = parse_block(0);
1437
1438         /* add '();' to make function return nothing by default */
1439         /* (otherwise the invisible parameter initialization can "leak" into
1440            the return value: fun ($x) {}->("asdf", 0) == 2) */
1441         if (*prelude_sentinel) {
1442                 body = newSTATEOP(0, NULL, body);
1443         }
1444
1445         body = op_append_list(OP_LINESEQ, *prelude_sentinel, body);
1446         *prelude_sentinel = NULL;
1447
1448         /* it's go time. */
1449         {
1450                 OP *const attrs = *attrs_sentinel;
1451                 *attrs_sentinel = NULL;
1452                 SvREFCNT_inc_simple_void(PL_compcv);
1453
1454                 /* close outer block: '}' */
1455                 S_block_end(aTHX_ save_ix, body);
1456
1457                 if (!saw_name) {
1458                         *pop = newANONATTRSUB(
1459                                 floor_ix,
1460                                 proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
1461                                 attrs,
1462                                 body
1463                         );
1464                         return KEYWORD_PLUGIN_EXPR;
1465                 }
1466
1467                 newATTRSUB(
1468                         floor_ix,
1469                         newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)),
1470                         proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
1471                         attrs,
1472                         body
1473                 );
1474                 *pop = newOP(OP_NULL, 0);
1475                 return KEYWORD_PLUGIN_STMT;
1476         }
1477 }
1478
1479 static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
1480         KWSpec spec;
1481         int ret;
1482
1483         SAVETMPS;
1484
1485         if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) {
1486                 ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec);
1487         } else {
1488                 ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
1489         }
1490
1491         FREETMPS;
1492
1493         return ret;
1494 }
1495
1496 WARNINGS_RESET
1497
1498 MODULE = Function::Parameters   PACKAGE = Function::Parameters
1499 PROTOTYPES: ENABLE
1500
1501 BOOT:
1502 WARNINGS_ENABLE {
1503         HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
1504         /**/
1505         newCONSTSUB(stash, "FLAG_NAME_OK",      newSViv(FLAG_NAME_OK));
1506         newCONSTSUB(stash, "FLAG_ANON_OK",      newSViv(FLAG_ANON_OK));
1507         newCONSTSUB(stash, "FLAG_DEFAULT_ARGS", newSViv(FLAG_DEFAULT_ARGS));
1508         newCONSTSUB(stash, "FLAG_CHECK_NARGS",  newSViv(FLAG_CHECK_NARGS));
1509         newCONSTSUB(stash, "FLAG_INVOCANT",     newSViv(FLAG_INVOCANT));
1510         newCONSTSUB(stash, "FLAG_NAMED_PARAMS", newSViv(FLAG_NAMED_PARAMS));
1511         newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
1512         newCONSTSUB(stash, "HINTK_FLAGS_",   newSVpvs(HINTK_FLAGS_));
1513         newCONSTSUB(stash, "HINTK_SHIFT_",   newSVpvs(HINTK_SHIFT_));
1514         newCONSTSUB(stash, "HINTK_ATTRS_",   newSVpvs(HINTK_ATTRS_));
1515         /**/
1516         next_keyword_plugin = PL_keyword_plugin;
1517         PL_keyword_plugin = my_keyword_plugin;
1518 } WARNINGS_RESET