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 };
 454
 455 DEFVECTOR_INIT(pv_init, Param);
 456 DEFVECTOR_INIT(piv_init, ParamInit);
 457
 458 static void p_init(Param *p) {
 459         p->name = NULL;
 460         p->padoff = NOT_IN_PAD;
 461 }
 462
 463 static 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
 482 DEFVECTOR_EXTEND(pv_extend, Param);
 483 DEFVECTOR_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
 495 static void p_clear(pTHX_ Param *p) {
 496         p->name = NULL;
 497         p->padoff = NOT_IN_PAD;
 498 }
 499
 500 static 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
 508 DEFVECTOR_CLEAR(pv_clear, Param, p_clear);
 509 DEFVECTOR_CLEAR(piv_clear, ParamInit, pi_clear);
 510
 511 static 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
 523 static 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
 557 static void ps_free_void(pTHX_ void *p) {
 558         ps_clear(aTHX_ p);
 559         Safefree(p);
 560 }
 561
 562 static 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
 575 static 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
 591 static size_t count_positional_params(const ParamSpec *ps) {
 592         return ps->positional_required.used + ps->positional_optional.used;
 593 }
 594
 595 static size_t count_named_params(const ParamSpec *ps) {
 596         return ps->named_required.used + ps->named_optional.used;
 597 }
 598
 599 enum {
 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  */
 607 static 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
 684 static 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
 690 static OP *my_var(pTHX_ I32 flags, PADOFFSET padoff) {
 691         return my_var_g(aTHX_ OP_PADSV, flags, padoff);
 692 }
 693
 694 static 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
 710 static 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
 733 static 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
 740 static OP *mkargselemv(pTHX_ PADOFFSET v) {
 741         return mkargselem(aTHX_ my_var(aTHX_ 0, v));
 742 }
 743
 744 static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const KWSpec *spec) {
 745         ParamSpec *param_spec;
 746         SV *declarator;
 747         I32 floor_ix;
 748         int save_ix;
 749         SV *saw_name;
 750         OP **prelude_sentinel;
 751         SV *proto;
 752         OP **attrs_sentinel, *body;
 753         unsigned builtin_attrs;
 754         I32 c;
 755
 756         declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len));
 757
 758         lex_read_space(0);
 759
 760         builtin_attrs = 0;
 761
 762         /* function name */
 763         saw_name = NULL;
 764         if ((spec->flags & FLAG_NAME_OK) && (saw_name = my_scan_word(aTHX_ TRUE))) {
 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
 771                 sv_catpvs(declarator, " ");
 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
 784                 lex_read_space(0);
 785         } else if (!(spec->flags & FLAG_ANON_OK)) {
 786                 croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - PL_parser->bufptr), PL_parser->bufptr);
 787         } else {
 788                 sv_catpvs(declarator, " (anon)");
 789         }
 790
 791         /* we're a subroutine declaration */
 792         floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON);
 793         SAVEFREESV(PL_compcv);
 794
 795         /* create outer block: '{' */
 796         save_ix = S_block_start(aTHX_ TRUE);
 797
 798         /* initialize synthetic optree */
 799         Newx(prelude_sentinel, 1, OP *);
 800         *prelude_sentinel = NULL;
 801         SAVEDESTRUCTOR_X(free_ptr_op, prelude_sentinel);
 802
 803         /* parameters */
 804         param_spec = NULL;
 805
 806         c = lex_peek_unichar(0);
 807         if (c == '(') {
 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);
 817
 818                 lex_read_unichar(0);
 819                 lex_read_space(0);
 820
 821                 while ((c = lex_peek_unichar(0)) != ')') {
 822                         int flags;
 823                         SV *name;
 824                         char sigil;
 825                         PADOFFSET padoff;
 826
 827                         padoff = parse_param(aTHX_ declarator, spec, param_spec, &flags, &name, init_sentinel);
 828
 829                         S_intro_my(aTHX);
 830
 831                         sigil = SvPV_nolen(name)[0];
 832
 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));
 837                                 }
 838                                 if (sigil != '$') {
 839                                         croak("In %"SVf": named parameter %"SVf" can't be a%s", SVfARG(declarator), SVfARG(name), sigil == '@' ? "n array" : " hash");
 840                                 }
 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));
 844                                 }
 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                         }
 851
 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                         }
 862
 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                         }
 866
 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));
 873                                 }
 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                         }
 881
 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                         }
 885
 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                         }
 889
 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));
 893                                 }
 894
 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                                         }
 906
 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++;
 925                                 }
 926                         }
 927
 928                 }
 929                 lex_read_unichar(0);
 930                 lex_read_space(0);
 931                 *init_sentinel = NULL;
 932
 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));
 936                         }
 937
 938                         param_spec->invocant.name = spec->shift;
 939                         param_spec->invocant.padoff = pad_add_name_sv(param_spec->invocant.name, 0, NULL, NULL);
 940                 }
 941         }
 942
 943         /* prototype */
 944         proto = NULL;
 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 != '(') {
 952                         lex_stuff_pvs(":", 0);
 953                         c = ':';
 954                 } else {
 955                         lex_read_unichar(0);
 956                         if (!(proto = my_scan_parens_tail(aTHX_ FALSE))) {
 957                                 croak("In %"SVf": prototype not terminated", SVfARG(declarator));
 958                         }
 959                         my_check_prototype(aTHX_ declarator, proto);
 960                         lex_read_space(0);
 961                         c = lex_peek_unichar(0);
 962                 }
 963         }
 964
 965         /* attributes */
 966         Newx(attrs_sentinel, 1, OP *);
 967         *attrs_sentinel = NULL;
 968         SAVEDESTRUCTOR_X(free_ptr_op, attrs_sentinel);
 969
 970         if (c == ':' || c == '{') /* '}' - hi, vim */ {
 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                 }
 977
 978                 if (c == ':') {
 979                         lex_read_unichar(0);
 980                         lex_read_space(0);
 981                         c = lex_peek_unichar(0);
 982
 983                         for (;;) {
 984                                 SV *attr;
 985
 986                                 if (!(attr = my_scan_word(aTHX_ FALSE))) {
 987                                         break;
 988                                 }
 989
 990                                 lex_read_space(0);
 991                                 c = lex_peek_unichar(0);
 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 {
1002                                         SV *sv;
1003                                         lex_read_unichar(0);
1004                                         if (!(sv = my_scan_parens_tail(aTHX_ TRUE))) {
1005                                                 croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator));
1006                                         }
1007                                         sv_catpvs(attr, "(");
1008                                         sv_catsv(attr, sv);
1009                                         sv_catpvs(attr, ")");
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                                 }
1024                         }
1025                 }
1026         }
1027
1028         /* body */
1029         if (c != '{') /* '}' - hi, vim */ {
1030                 croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c);
1031         }
1032
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
1051         if (builtin_attrs & MY_ATTR_LVALUE) {
1052                 CvLVALUE_on(PL_compcv);
1053         }
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);
1059         }
1060
1061         /* check number of arguments */
1062         if (spec->flags & FLAG_CHECK_NARGS) {
1063                 int amin, amax;
1064                 size_t named;
1065
1066                 amin = args_min(aTHX_ param_spec, spec);
1067                 if (amin > 0) {
1068                         OP *chk, *cond, *err, *croak;
1069
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(")")));
1078
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));
1083
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));
1090                 }
1091
1092                 amax = args_max(param_spec);
1093                 if (amax >= 0) {
1094                         OP *chk, *cond, *err, *croak;
1095
1096                         err = newSVOP(OP_CONST, 0,
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(")")));
1104
1105                         croak = newCVREF(OPf_WANT_SCALAR,
1106                                              newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
1107                         err = newUNOP(OP_ENTERSUB, OPf_STACKED,
1108                                           op_append_elem(OP_LIST, err, croak));
1109
1110                         cond = newBINOP(OP_GT, 0,
1111                                             newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1112                                             newSVOP(OP_CONST, 0, newSViv(amax)));
1113                         chk = newLOGOP(OP_AND, 0, cond, err);
1114
1115                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
1116                 }
1117
1118                 if (param_spec && (count_named_params(param_spec) || (param_spec->slurpy.name && SvPV_nolen(param_spec->slurpy.name)[0] == '%'))) {
1119                         OP *chk, *cond, *err, *croak;
1120                         const UV fixed = count_positional_params(param_spec) + !!param_spec->invocant.name;
1121
1122                         err = newSVOP(OP_CONST, 0,
1123                                           newSVpvf("Odd number of paired arguments for %"SVf"", SVfARG(declarator)));
1124
1125                         croak = newCVREF(OPf_WANT_SCALAR,
1126                                              newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
1127                         err = newUNOP(OP_ENTERSUB, OPf_STACKED,
1128                                           op_append_elem(OP_LIST, err, croak));
1129
1130                         cond = newBINOP(OP_GT, 0,
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))));
1146                         chk = newLOGOP(OP_AND, 0, cond, err);
1147
1148                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
1149                 }
1150         }
1151
1152         if (!param_spec) {
1153                 /* my $invocant = shift; */
1154                 if (SvTRUE(spec->shift)) {
1155                         OP *var;
1156
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));
1163
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;
1170
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));
1177
1178                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
1179                 }
1180
1181                 /* my (...) = @_; */
1182                 {
1183                         OP *lhs;
1184                         size_t i, lim;
1185
1186                         lhs = NULL;
1187
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                         }
1196
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                         }
1205
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                         }
1225
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                 }
1240
1241                 /* default arguments */
1242                 {
1243                         size_t i, lim, req;
1244                         OP *nest;
1245
1246                         nest = NULL;
1247
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;
1252
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                                 );
1258
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                         );
1278                 }
1279
1280                 /* named parameters */
1281                 if (count_named_params(param_spec)) {
1282                         int nameblock_ix;
1283                         OP *nameblock;
1284                         PADOFFSET vb, vc, vi, vk;
1285                         int vb_is_str, vc_is_str;
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
1296                                 vb_is_str = param_spec->named_required.used > UV_BITS;
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);
1302                                         var = newASSIGNOP(OPf_STACKED, var, 0, newSVOP(OP_CONST, 0, vb_is_str ? newSVpvs("") : newSVuv(0)));
1303                                         decl = op_append_list(OP_LINESEQ, decl, newSTATEOP(0, NULL, var));
1304                                 }
1305
1306                                 vc_is_str = param_spec->named_optional.used > UV_BITS;
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);
1312                                         var = newASSIGNOP(OPf_STACKED, var, 0, newSVOP(OP_CONST, 0, vc_is_str ? newSVpvs("") : newSVuv(0)));
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,
1401                                                               newSVpvf("In %"SVf": no such named parameter: ", SVfARG(declarator)));
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;
1424                                                 } else if (vc_is_str) {
1425                                                         vec = newASSIGNOP(
1426                                                                 OPf_STACKED,
1427                                                                 mkvecbits(aTHX_ vc, i),
1428                                                                 0,
1429                                                                 newSVOP(OP_CONST, 0, newSViv(1))
1430                                                         );
1431                                                 } else {
1432                                                         vec = newASSIGNOP(
1433                                                                 OPf_STACKED,
1434                                                                 my_var(aTHX_ 0, vc),
1435                                                                 OP_BIT_OR,
1436                                                                 newSVOP(OP_CONST, 0, newSVuv((UV)1 << i))
1437                                                         );
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;
1476                                                 } else if (vb_is_str) {
1477                                                         vec = newASSIGNOP(
1478                                                                 OPf_STACKED,
1479                                                                 mkvecbits(aTHX_ vb, i),
1480                                                                 0,
1481                                                                 newSVOP(OP_CONST, 0, newSViv(1))
1482                                                         );
1483                                                 } else {
1484                                                         vec = newASSIGNOP(
1485                                                                 OPf_STACKED,
1486                                                                 my_var(aTHX_ 0, vb),
1487                                                                 OP_BIT_OR,
1488                                                                 newSVOP(OP_CONST, 0, newSVuv((UV)1 << i))
1489                                                         );
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,
1561                                                         vb_is_str
1562                                                                 ? mkvecbits(aTHX_ vb, i)
1563                                                                 : newBINOP(OP_BIT_AND, 0, my_var(aTHX_ 0, vb), newSVOP(OP_CONST, 0, newSVuv((UV)1 << i)))
1564                                                         ,
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,
1585                                         newSVpvf("In %"SVf": missing named parameter(s): ", SVfARG(declarator))
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                                 );
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                                 }
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
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(aTHX_ 0, vc), newSVOP(OP_CONST, 0, newSVuv((UV)1 << i)))
1647                                         );
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                 }
1660         }
1661
1662         /* finally let perl parse the actual subroutine body */
1663         body = parse_block(0);
1664
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);
1670         }
1671
1672         body = op_append_list(OP_LINESEQ, *prelude_sentinel, body);
1673         *prelude_sentinel = NULL;
1674
1675         /* it's go time. */
1676         {
1677                 OP *const attrs = *attrs_sentinel;
1678                 *attrs_sentinel = NULL;
1679                 SvREFCNT_inc_simple_void(PL_compcv);
1680
1681                 /* close outer block: '}' */
1682                 S_block_end(aTHX_ save_ix, body);
1683
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                 );
1701                 *pop = newOP(OP_NULL, 0);
1702                 return KEYWORD_PLUGIN_STMT;
1703         }
1704 }
1705
1706 static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
1707         KWSpec spec;
1708         int ret;
1709
1710         SAVETMPS;
1711
1712         if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) {
1713                 ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec);
1714         } else {
1715                 ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
1716         }
1717
1718         FREETMPS;
1719
1720         return ret;
1721 }
1722
1723 WARNINGS_RESET
1724
1725 MODULE = Function::Parameters   PACKAGE = Function::Parameters
1726 PROTOTYPES: ENABLE
1727
1728 BOOT:
1729 WARNINGS_ENABLE {
1730         HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
1731         /**/
1732         newCONSTSUB(stash, "FLAG_NAME_OK",      newSViv(FLAG_NAME_OK));
1733         newCONSTSUB(stash, "FLAG_ANON_OK",      newSViv(FLAG_ANON_OK));
1734         newCONSTSUB(stash, "FLAG_DEFAULT_ARGS", newSViv(FLAG_DEFAULT_ARGS));
1735         newCONSTSUB(stash, "FLAG_CHECK_NARGS",  newSViv(FLAG_CHECK_NARGS));
1736         newCONSTSUB(stash, "FLAG_INVOCANT",     newSViv(FLAG_INVOCANT));
1737         newCONSTSUB(stash, "FLAG_NAMED_PARAMS", newSViv(FLAG_NAMED_PARAMS));
1738         newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
1739         newCONSTSUB(stash, "HINTK_FLAGS_",   newSVpvs(HINTK_FLAGS_));
1740         newCONSTSUB(stash, "HINTK_SHIFT_",   newSVpvs(HINTK_SHIFT_));
1741         newCONSTSUB(stash, "HINTK_ATTRS_",   newSVpvs(HINTK_ATTRS_));
1742         /**/
1743         next_keyword_plugin = PL_keyword_plugin;
1744         PL_keyword_plugin = my_keyword_plugin;
1745 } WARNINGS_RESET