op.c

   1 /* $RCSfile: cmd.h,v $$Revision: 4.1 $$Date: 92/08/07 17:19:19 $
   2  *
   3  *    Copyright (c) 1991, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  * $Log:        cmd.h,v $
   9  */
  10
  11 #include "EXTERN.h"
  12 #include "perl.h"
  13
  14 /* Lowest byte of opargs */
  15 #define OA_MARK 1
  16 #define OA_FOLDCONST 2
  17 #define OA_RETSCALAR 4
  18 #define OA_TARGET 8
  19 #define OA_RETINTEGER 16
  20 #define OA_OTHERINT 32
  21 #define OA_DANGEROUS 64
  22
  23 /* Remaining nybbles of opargs */
  24 #define OA_SCALAR 1
  25 #define OA_LIST 2
  26 #define OA_AVREF 3
  27 #define OA_HVREF 4
  28 #define OA_CVREF 5
  29 #define OA_FILEREF 6
  30 #define OA_SCALARREF 7
  31 #define OA_OPTIONAL 8
  32
  33 void
  34 cpy7bit(d,s,l)
  35 register char *d;
  36 register char *s;
  37 register I32 l;
  38 {
  39     while (l--)
  40         *d++ = *s++ & 127;
  41     *d = '\0';
  42 }
  43
  44 static OP *
  45 no_fh_allowed(op)
  46 OP *op;
  47 {
  48     sprintf(tokenbuf,"Missing comma after first argument to %s function",
  49         op_name[op->op_type]);
  50     yyerror(tokenbuf);
  51     return op;
  52 }
  53
  54 static OP *
  55 too_few_arguments(op)
  56 OP *op;
  57 {
  58     sprintf(tokenbuf,"Not enough arguments for %s", op_name[op->op_type]);
  59     yyerror(tokenbuf);
  60     return op;
  61 }
  62
  63 static OP *
  64 too_many_arguments(op)
  65 OP *op;
  66 {
  67     sprintf(tokenbuf,"Too many arguments for %s", op_name[op->op_type]);
  68     yyerror(tokenbuf);
  69     return op;
  70 }
  71
  72 static OP *
  73 bad_type(n, t, op, kid)
  74 I32 n;
  75 char *t;
  76 OP *op;
  77 OP *kid;
  78 {
  79     sprintf(tokenbuf, "Type of arg %d to %s must be %s (not %s)",
  80         n, op_name[op->op_type], t, op_name[kid->op_type]);
  81     yyerror(tokenbuf);
  82     return op;
  83 }
  84
  85 /* "register" allocation */
  86
  87 PADOFFSET
  88 pad_allocmy(name)
  89 char *name;
  90 {
  91     PADOFFSET off = pad_alloc(OP_PADSV, SVs_PADMY);
  92     SV *sv = NEWSV(0,0);
  93     sv_upgrade(sv, SVt_PVNV);
  94     sv_setpv(sv, name);
  95     av_store(comppad_name, off, sv);
  96     SvNVX(sv) = (double)cop_seqmax;
  97     SvIVX(sv) = 0;                      /* Not yet introduced--see newSTATEOP */
  98     if (!min_intro_pending)
  99         min_intro_pending = off;
 100     max_intro_pending = off;
 101     if (*name == '@')
 102         av_store(comppad, off, (SV*)newAV());
 103     else if (*name == '%')
 104         av_store(comppad, off, (SV*)newHV());
 105     SvPADMY_on(curpad[off]);
 106     return off;
 107 }
 108
 109 PADOFFSET
 110 pad_findmy(name)
 111 char *name;
 112 {
 113     I32 off;
 114     SV *sv;
 115     SV **svp = AvARRAY(comppad_name);
 116     register I32 i;
 117     register CONTEXT *cx;
 118     bool saweval;
 119     AV *curlist;
 120     AV *curname;
 121     CV *cv;
 122     I32 seq = cop_seqmax;
 123
 124     /* The one we're looking for is probably just before comppad_name_fill. */
 125     for (off = comppad_name_fill; off > 0; off--) {
 126         if ((sv = svp[off]) &&
 127             seq <= SvIVX(sv) &&
 128             seq > (I32)SvNVX(sv) &&
 129             strEQ(SvPVX(sv), name))
 130         {
 131             return (PADOFFSET)off;
 132         }
 133     }
 134
 135     /* Nothing in current lexical context--try eval's context, if any.
 136      * This is necessary to let the perldb get at lexically scoped variables.
 137      * XXX This will also probably interact badly with eval tree caching.
 138      */
 139
 140     saweval = FALSE;
 141     for (i = cxstack_ix; i >= 0; i--) {
 142         cx = &cxstack[i];
 143         switch (cx->cx_type) {
 144         default:
 145             break;
 146         case CXt_EVAL:
 147             saweval = TRUE;
 148             break;
 149         case CXt_SUB:
 150             if (!saweval)
 151                 return 0;
 152             cv = cx->blk_sub.cv;
 153             if (debstash && CvSTASH(cv) == debstash)    /* ignore DB'* scope */
 154                 continue;
 155             seq = cxstack[i+1].blk_oldcop->cop_seq;
 156             curlist = CvPADLIST(cv);
 157             curname = (AV*)*av_fetch(curlist, 0, FALSE);
 158             svp = AvARRAY(curname);
 159             for (off = AvFILL(curname); off > 0; off--) {
 160                 if ((sv = svp[off]) &&
 161                     seq <= SvIVX(sv) &&
 162                     seq > (I32)SvNVX(sv) &&
 163                     strEQ(SvPVX(sv), name))
 164                 {
 165                     PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
 166                     AV *oldpad = (AV*)*av_fetch(curlist, CvDEPTH(cv), FALSE);
 167                     SV *oldsv = *av_fetch(oldpad, off, TRUE);
 168                     SV *sv = NEWSV(0,0);
 169                     sv_upgrade(sv, SVt_PVNV);
 170                     sv_setpv(sv, name);
 171                     av_store(comppad_name, newoff, sv);
 172                     SvNVX(sv) = (double)curcop->cop_seq;
 173                     SvIVX(sv) = 999999999;      /* A ref, intro immediately */
 174                     av_store(comppad, newoff, SvREFCNT_inc(oldsv));
 175                     return newoff;
 176                 }
 177             }
 178             return 0;
 179         }
 180     }
 181
 182     return 0;
 183 }
 184
 185 void
 186 pad_leavemy(fill)
 187 I32 fill;
 188 {
 189     I32 off;
 190     SV **svp = AvARRAY(comppad_name);
 191     SV *sv;
 192     if (min_intro_pending && fill < min_intro_pending) {
 193         for (off = max_intro_pending; off >= min_intro_pending; off--) {
 194             if (sv = svp[off])
 195                 warn("%s never introduced", SvPVX(sv));
 196         }
 197     }
 198     /* "Deintroduce" my variables that are leaving with this scope. */
 199     for (off = AvFILL(comppad_name); off > fill; off--) {
 200         if (sv = svp[off])
 201             SvIVX(sv) = cop_seqmax;
 202     }
 203 }
 204
 205 PADOFFSET
 206 pad_alloc(optype,tmptype)
 207 I32 optype;
 208 U32 tmptype;
 209 {
 210     SV *sv;
 211     I32 retval;
 212
 213     if (AvARRAY(comppad) != curpad)
 214         croak("panic: pad_alloc");
 215     if (tmptype & SVs_PADMY) {
 216         do {
 217             sv = *av_fetch(comppad, AvFILL(comppad) + 1, TRUE);
 218         } while (SvPADBUSY(sv));                /* need a fresh one */
 219         retval = AvFILL(comppad);
 220     }
 221     else {
 222         do {
 223             sv = *av_fetch(comppad, ++padix, TRUE);
 224         } while (SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY));
 225         retval = padix;
 226     }
 227     SvFLAGS(sv) |= tmptype;
 228     curpad = AvARRAY(comppad);
 229     DEBUG_X(fprintf(stderr, "Pad alloc %d for %s\n", retval, op_name[optype]));
 230     return (PADOFFSET)retval;
 231 }
 232
 233 SV *
 234 #ifndef STANDARD_C
 235 pad_sv(po)
 236 PADOFFSET po;
 237 #else
 238 pad_sv(PADOFFSET po)
 239 #endif /* STANDARD_C */
 240 {
 241     if (!po)
 242         croak("panic: pad_sv po");
 243     DEBUG_X(fprintf(stderr, "Pad sv %d\n", po));
 244     return curpad[po];          /* eventually we'll turn this into a macro */
 245 }
 246
 247 void
 248 #ifndef STANDARD_C
 249 pad_free(po)
 250 PADOFFSET po;
 251 #else
 252 pad_free(PADOFFSET po)
 253 #endif /* STANDARD_C */
 254 {
 255     if (AvARRAY(comppad) != curpad)
 256         croak("panic: pad_free curpad");
 257     if (!po)
 258         croak("panic: pad_free po");
 259     DEBUG_X(fprintf(stderr, "Pad free %d\n", po));
 260     if (curpad[po])
 261         SvPADTMP_off(curpad[po]);
 262     if (po < padix)
 263         padix = po - 1;
 264 }
 265
 266 void
 267 #ifndef STANDARD_C
 268 pad_swipe(po)
 269 PADOFFSET po;
 270 #else
 271 pad_swipe(PADOFFSET po)
 272 #endif /* STANDARD_C */
 273 {
 274     if (AvARRAY(comppad) != curpad)
 275         croak("panic: pad_swipe curpad");
 276     if (!po)
 277         croak("panic: pad_swipe po");
 278     DEBUG_X(fprintf(stderr, "Pad swipe %d\n", po));
 279     curpad[po] = NEWSV(0,0);
 280     SvPADTMP_off(curpad[po]);
 281     if (po < padix)
 282         padix = po - 1;
 283 }
 284
 285 void
 286 pad_reset()
 287 {
 288     register I32 po;
 289
 290     if (AvARRAY(comppad) != curpad)
 291         croak("panic: pad_reset curpad");
 292     DEBUG_X(fprintf(stderr, "Pad reset\n"));
 293     for (po = AvMAX(comppad); po > 0; po--) {
 294         if (curpad[po])
 295             SvPADTMP_off(curpad[po]);
 296     }
 297     padix = 0;
 298 }
 299
 300 /* Destructor */
 301
 302 void
 303 op_free(op)
 304 OP *op;
 305 {
 306     register OP *kid, *nextkid;
 307
 308     if (!op)
 309         return;
 310
 311     if (op->op_flags & OPf_KIDS) {
 312         for (kid = cUNOP->op_first; kid; kid = nextkid) {
 313             nextkid = kid->op_sibling; /* Get before next freeing kid */
 314             op_free(kid);
 315         }
 316     }
 317
 318
 319     switch (op->op_type) {
 320     case OP_NULL:
 321         op->op_targ = 0;        /* Was holding old type, if any. */
 322         break;
 323     case OP_GVSV:
 324     case OP_GV:
 325         SvREFCNT_dec((SV*)cGVOP->op_gv);
 326         break;
 327     case OP_NEXTSTATE:
 328     case OP_DBSTATE:
 329         SvREFCNT_dec(cCOP->cop_filegv);
 330         break;
 331     case OP_CONST:
 332         SvREFCNT_dec(cSVOP->op_sv);
 333         break;
 334     }
 335
 336     if (op->op_targ > 0)
 337         pad_free(op->op_targ);
 338
 339     Safefree(op);
 340 }
 341
 342 static void
 343 null(op)
 344 OP* op;
 345 {
 346     if (op->op_type != OP_NULL && op->op_targ > 0)
 347         pad_free(op->op_targ);
 348     op->op_targ = op->op_type;
 349     op->op_type = OP_NULL;
 350     op->op_ppaddr = ppaddr[OP_NULL];
 351 }
 352
 353 static void
 354 unlist(op)
 355 OP* op;
 356 {
 357     OP* kid = cLISTOP->op_first;
 358     assert(kid->op_type == OP_PUSHMARK);
 359     cLISTOP->op_first = kid->op_sibling;
 360     null(kid);
 361     null(op);
 362 }
 363
 364 /* Contextualizers */
 365
 366 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 367
 368 OP *
 369 linklist(op)
 370 OP *op;
 371 {
 372     register OP *kid;
 373
 374     if (op->op_next)
 375         return op->op_next;
 376
 377     /* establish postfix order */
 378     if (cUNOP->op_first) {
 379         op->op_next = LINKLIST(cUNOP->op_first);
 380         for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
 381             if (kid->op_sibling)
 382                 kid->op_next = LINKLIST(kid->op_sibling);
 383             else
 384                 kid->op_next = op;
 385         }
 386     }
 387     else
 388         op->op_next = op;
 389
 390     return op->op_next;
 391 }
 392
 393 OP *
 394 scalarkids(op)
 395 OP *op;
 396 {
 397     OP *kid;
 398     if (op && op->op_flags & OPf_KIDS) {
 399         for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
 400             scalar(kid);
 401     }
 402     return op;
 403 }
 404
 405 OP *
 406 scalarboolean(op)
 407 OP *op;
 408 {
 409     if (dowarn &&
 410         op->op_type == OP_SASSIGN && cBINOP->op_first->op_type == OP_CONST)
 411             warn("Found = in conditional, should be ==");
 412     return scalar(op);
 413 }
 414
 415 OP *
 416 scalar(op)
 417 OP *op;
 418 {
 419     OP *kid;
 420
 421     if (!op || (op->op_flags & OPf_KNOW)) /* assumes no premature commitment */
 422         return op;
 423
 424     op->op_flags &= ~OPf_LIST;
 425     op->op_flags |= OPf_KNOW;
 426
 427     switch (op->op_type) {
 428     case OP_REPEAT:
 429         scalar(cBINOP->op_first);
 430         break;
 431     case OP_OR:
 432     case OP_AND:
 433     case OP_COND_EXPR:
 434         for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
 435             scalar(kid);
 436         break;
 437     case OP_MATCH:
 438     case OP_SUBST:
 439     case OP_NULL:
 440     default:
 441         if (op->op_flags & OPf_KIDS) {
 442             for (kid = cUNOP->op_first; kid; kid = kid->op_sibling)
 443                 scalar(kid);
 444         }
 445         break;
 446     case OP_SCOPE:
 447     case OP_LEAVE:
 448     case OP_LEAVETRY:
 449     case OP_LINESEQ:
 450     case OP_LIST:
 451         for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) {
 452             if (kid->op_sibling)
 453                 scalarvoid(kid);
 454             else
 455                 scalar(kid);
 456         }
 457         curcop = &compiling;
 458         break;
 459     }
 460     return op;
 461 }
 462
 463 OP *
 464 scalarvoid(op)
 465 OP *op;
 466 {
 467     OP *kid;
 468     char* useless = 0;
 469     SV* sv;
 470
 471     if (!op)
 472         return op;
 473     if (op->op_flags & OPf_LIST)
 474         return op;
 475
 476     op->op_flags |= OPf_KNOW;
 477
 478     switch (op->op_type) {
 479     default:
 480         if (!(opargs[op->op_type] & OA_FOLDCONST))
 481             break;
 482         if (op->op_flags & OPf_STACKED)
 483             break;
 484         /* FALL THROUGH */
 485     case OP_GVSV:
 486     case OP_WANTARRAY:
 487     case OP_GV:
 488     case OP_PADSV:
 489     case OP_PADAV:
 490     case OP_PADHV:
 491     case OP_PADANY:
 492     case OP_AV2ARYLEN:
 493     case OP_SV2LEN:
 494     case OP_REF:
 495     case OP_DEFINED:
 496     case OP_HEX:
 497     case OP_OCT:
 498     case OP_LENGTH:
 499     case OP_SUBSTR:
 500     case OP_VEC:
 501     case OP_INDEX:
 502     case OP_RINDEX:
 503     case OP_SPRINTF:
 504     case OP_AELEM:
 505     case OP_AELEMFAST:
 506     case OP_ASLICE:
 507     case OP_VALUES:
 508     case OP_KEYS:
 509     case OP_HELEM:
 510     case OP_HSLICE:
 511     case OP_UNPACK:
 512     case OP_PACK:
 513     case OP_JOIN:
 514     case OP_LSLICE:
 515     case OP_ANONLIST:
 516     case OP_ANONHASH:
 517     case OP_SORT:
 518     case OP_REVERSE:
 519     case OP_RANGE:
 520     case OP_FLIP:
 521     case OP_FLOP:
 522     case OP_CALLER:
 523     case OP_FILENO:
 524     case OP_EOF:
 525     case OP_TELL:
 526     case OP_GETSOCKNAME:
 527     case OP_GETPEERNAME:
 528     case OP_READLINK:
 529     case OP_TELLDIR:
 530     case OP_GETPPID:
 531     case OP_GETPGRP:
 532     case OP_GETPRIORITY:
 533     case OP_TIME:
 534     case OP_TMS:
 535     case OP_LOCALTIME:
 536     case OP_GMTIME:
 537     case OP_GHBYNAME:
 538     case OP_GHBYADDR:
 539     case OP_GHOSTENT:
 540     case OP_GNBYNAME:
 541     case OP_GNBYADDR:
 542     case OP_GNETENT:
 543     case OP_GPBYNAME:
 544     case OP_GPBYNUMBER:
 545     case OP_GPROTOENT:
 546     case OP_GSBYNAME:
 547     case OP_GSBYPORT:
 548     case OP_GSERVENT:
 549     case OP_GPWNAM:
 550     case OP_GPWUID:
 551     case OP_GGRNAM:
 552     case OP_GGRGID:
 553     case OP_GETLOGIN:
 554         if (!(op->op_flags & OPf_INTRO))
 555             useless = op_name[op->op_type];
 556         break;
 557
 558     case OP_RV2GV:
 559     case OP_RV2SV:
 560     case OP_RV2AV:
 561     case OP_RV2HV:
 562         if (!(op->op_flags & OPf_INTRO) &&
 563                 (!op->op_sibling || op->op_sibling->op_type != OP_READLINE))
 564             useless = "a variable";
 565         break;
 566
 567     case OP_NEXTSTATE:
 568     case OP_DBSTATE:
 569         curcop = ((COP*)op);            /* for warning above */
 570         break;
 571
 572     case OP_CONST:
 573         sv = cSVOP->op_sv;
 574         if (dowarn) {
 575             useless = "a constant";
 576             if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
 577                 useless = 0;
 578             else if (SvPOK(sv)) {
 579                 if (strnEQ(SvPVX(sv), "di", 2) ||
 580                     strnEQ(SvPVX(sv), "ig", 2))
 581                         useless = 0;
 582             }
 583         }
 584         null(op);               /* don't execute a constant */
 585         SvREFCNT_dec(sv);       /* don't even remember it */
 586         break;
 587
 588     case OP_POSTINC:
 589         op->op_type = OP_PREINC;                /* pre-increment is faster */
 590         op->op_ppaddr = ppaddr[OP_PREINC];
 591         break;
 592
 593     case OP_POSTDEC:
 594         op->op_type = OP_PREDEC;                /* pre-decrement is faster */
 595         op->op_ppaddr = ppaddr[OP_PREDEC];
 596         break;
 597
 598     case OP_REPEAT:
 599         scalarvoid(cBINOP->op_first);
 600         useless = op_name[op->op_type];
 601         break;
 602
 603     case OP_OR:
 604     case OP_AND:
 605     case OP_COND_EXPR:
 606         for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
 607             scalarvoid(kid);
 608         break;
 609     case OP_ENTERTRY:
 610     case OP_ENTER:
 611     case OP_SCALAR:
 612     case OP_NULL:
 613         if (!(op->op_flags & OPf_KIDS))
 614             break;
 615     case OP_SCOPE:
 616     case OP_LEAVE:
 617     case OP_LEAVETRY:
 618     case OP_LINESEQ:
 619     case OP_LIST:
 620         for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
 621             scalarvoid(kid);
 622         break;
 623     }
 624     if (useless && dowarn)
 625         warn("Useless use of %s in void context", useless);
 626     return op;
 627 }
 628
 629 OP *
 630 listkids(op)
 631 OP *op;
 632 {
 633     OP *kid;
 634     if (op && op->op_flags & OPf_KIDS) {
 635         for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
 636             list(kid);
 637     }
 638     return op;
 639 }
 640
 641 OP *
 642 list(op)
 643 OP *op;
 644 {
 645     OP *kid;
 646
 647     if (!op || (op->op_flags & OPf_KNOW)) /* assumes no premature commitment */
 648         return op;
 649
 650     op->op_flags |= (OPf_KNOW | OPf_LIST);
 651
 652     switch (op->op_type) {
 653     case OP_FLOP:
 654     case OP_REPEAT:
 655         list(cBINOP->op_first);
 656         break;
 657     case OP_OR:
 658     case OP_AND:
 659     case OP_COND_EXPR:
 660         for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
 661             list(kid);
 662         break;
 663     default:
 664     case OP_MATCH:
 665     case OP_SUBST:
 666     case OP_NULL:
 667         if (!(op->op_flags & OPf_KIDS))
 668             break;
 669         if (!op->op_next && cUNOP->op_first->op_type == OP_FLOP) {
 670             list(cBINOP->op_first);
 671             return gen_constant_list(op);
 672         }
 673     case OP_LIST:
 674         listkids(op);
 675         break;
 676     case OP_SCOPE:
 677     case OP_LEAVE:
 678     case OP_LEAVETRY:
 679     case OP_LINESEQ:
 680         for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) {
 681             if (kid->op_sibling)
 682                 scalarvoid(kid);
 683             else
 684                 list(kid);
 685         }
 686         curcop = &compiling;
 687         break;
 688     }
 689     return op;
 690 }
 691
 692 OP *
 693 scalarseq(op)
 694 OP *op;
 695 {
 696     OP *kid;
 697
 698     if (op) {
 699         if (op->op_type == OP_LINESEQ ||
 700              op->op_type == OP_SCOPE ||
 701              op->op_type == OP_LEAVE ||
 702              op->op_type == OP_LEAVETRY)
 703         {
 704             for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) {
 705                 if (kid->op_sibling) {
 706                     scalarvoid(kid);
 707                 }
 708             }
 709             curcop = &compiling;
 710         }
 711         op->op_flags &= ~OPf_PARENS;
 712         if (hints & HINT_BLOCK_SCOPE)
 713             op->op_flags |= OPf_PARENS;
 714     }
 715     else
 716         op = newOP(OP_STUB, 0);
 717     return op;
 718 }
 719
 720 OP *
 721 modkids(op, type)
 722 OP *op;
 723 I32 type;
 724 {
 725     OP *kid;
 726     if (op && op->op_flags & OPf_KIDS) {
 727         for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
 728             mod(kid, type);
 729     }
 730     return op;
 731 }
 732
 733 static I32 modcount;
 734
 735 OP *
 736 mod(op, type)
 737 OP *op;
 738 I32 type;
 739 {
 740     OP *kid;
 741     SV *sv;
 742
 743     if (!op)
 744         return op;
 745
 746     switch (op->op_type) {
 747     case OP_ENTERSUBR:
 748         if ((type == OP_UNDEF) && !(op->op_flags & OPf_STACKED)) {
 749             op->op_type = OP_RV2CV;             /* entersubr => rv2cv */
 750             op->op_ppaddr = ppaddr[OP_RV2CV];
 751             assert(cUNOP->op_first->op_type == OP_NULL);
 752             null(((LISTOP*)cUNOP->op_first)->op_first); /* disable pushmark */
 753             break;
 754         }
 755         /* FALL THROUGH */
 756     default:
 757         sprintf(tokenbuf, "Can't modify %s in %s",
 758             op_name[op->op_type],
 759             type ? op_name[type] : "local");
 760         yyerror(tokenbuf);
 761         return op;
 762
 763     case OP_COND_EXPR:
 764         for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
 765             mod(kid, type);
 766         break;
 767
 768     case OP_RV2AV:
 769     case OP_RV2HV:
 770     case OP_RV2GV:
 771         op->op_private = (hints & HINT_STRICT_REFS);
 772         ref(cUNOP->op_first, op->op_type);
 773         /* FALL THROUGH */
 774     case OP_AASSIGN:
 775     case OP_ASLICE:
 776     case OP_HSLICE:
 777     case OP_NEXTSTATE:
 778     case OP_DBSTATE:
 779         modcount = 10000;
 780         break;
 781     case OP_RV2SV:
 782         op->op_private = (hints & HINT_STRICT_REFS);
 783         if (type == OP_RV2AV || type == OP_RV2HV)
 784             op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV);
 785         ref(cUNOP->op_first, op->op_type);
 786         /* FALL THROUGH */
 787     case OP_PADSV:
 788     case OP_PADAV:
 789     case OP_PADHV:
 790     case OP_UNDEF:
 791     case OP_GV:
 792     case OP_AV2ARYLEN:
 793     case OP_SASSIGN:
 794     case OP_AELEMFAST:
 795         modcount++;
 796         break;
 797
 798     case OP_REFGEN:
 799         modcount++;
 800         break;
 801
 802     case OP_PUSHMARK:
 803         break;
 804
 805     case OP_SUBSTR:
 806     case OP_VEC:
 807         pad_free(op->op_targ);
 808         op->op_targ = pad_alloc(op->op_type, SVs_PADMY);
 809         sv = PAD_SV(op->op_targ);
 810         sv_upgrade(sv, SVt_PVLV);
 811         sv_magic(sv, 0, op->op_type == OP_VEC ? 'v' : 'x', 0, 0);
 812         curpad[op->op_targ] = sv;
 813         /* FALL THROUGH */
 814     case OP_NULL:
 815         if (op->op_flags & OPf_KIDS)
 816             mod(cBINOP->op_first, type);
 817         break;
 818     case OP_AELEM:
 819     case OP_HELEM:
 820         ref(cBINOP->op_first, op->op_type);
 821         op->op_private = (hints & HINT_STRICT_REFS);
 822         if (type == OP_RV2AV || type == OP_RV2HV)
 823             op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV);
 824         break;
 825
 826     case OP_SCOPE:
 827     case OP_LEAVE:
 828     case OP_ENTER:
 829         if (!(op->op_flags & OPf_KIDS))
 830             break;
 831         mod(cLISTOP->op_last, type);
 832         break;
 833
 834     case OP_LIST:
 835         for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
 836             mod(kid, type);
 837         break;
 838     }
 839     op->op_flags |= OPf_LVAL;
 840     if (!type) {
 841         op->op_flags &= ~OPf_SPECIAL;
 842         op->op_flags |= OPf_INTRO;
 843     }
 844     else if (type == OP_AASSIGN || type == OP_SASSIGN)
 845         op->op_flags |= OPf_SPECIAL;
 846     return op;
 847 }
 848
 849 OP *
 850 refkids(op, type)
 851 OP *op;
 852 I32 type;
 853 {
 854     OP *kid;
 855     if (op && op->op_flags & OPf_KIDS) {
 856         for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
 857             ref(kid, type);
 858     }
 859     return op;
 860 }
 861
 862 OP *
 863 ref(op, type)
 864 OP *op;
 865 I32 type;
 866 {
 867     OP *kid;
 868     SV *sv;
 869
 870     if (!op)
 871         return op;
 872
 873     switch (op->op_type) {
 874     case OP_ENTERSUBR:
 875         if ((type == OP_REFGEN || type == OP_DEFINED)
 876             && !(op->op_flags & (OPf_STACKED|OPf_PARENS))) {
 877             op->op_type = OP_RV2CV;             /* entersubr => rv2cv */
 878             op->op_ppaddr = ppaddr[OP_RV2CV];
 879             assert(cUNOP->op_first->op_type == OP_NULL);
 880             null(((LISTOP*)cUNOP->op_first)->op_first); /* disable pushmark */
 881         }
 882         break;
 883
 884     case OP_COND_EXPR:
 885         for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
 886             ref(kid, type);
 887         break;
 888     case OP_RV2SV:
 889         op->op_private = (hints & HINT_STRICT_REFS);
 890         if (type == OP_RV2AV || type == OP_RV2HV)
 891             op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV);
 892         ref(cUNOP->op_first, op->op_type);
 893         break;
 894
 895     case OP_RV2AV:
 896     case OP_RV2HV:
 897         op->op_flags |= OPf_LVAL;
 898         /* FALL THROUGH */
 899     case OP_RV2GV:
 900         op->op_private = (hints & HINT_STRICT_REFS);
 901         ref(cUNOP->op_first, op->op_type);
 902         break;
 903
 904     case OP_PADAV:
 905     case OP_PADHV:
 906         op->op_flags |= OPf_LVAL;
 907         break;
 908
 909     case OP_SCALAR:
 910     case OP_NULL:
 911         if (!(op->op_flags & OPf_KIDS))
 912             break;
 913         ref(cBINOP->op_first, type);
 914         break;
 915     case OP_AELEM:
 916     case OP_HELEM:
 917         ref(cBINOP->op_first, op->op_type);
 918         op->op_private = (hints & HINT_STRICT_REFS);
 919         if (type == OP_RV2AV || type == OP_RV2HV || type == OP_REFGEN) {
 920             op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV :
 921                                 type == OP_RV2HV ? OPpDEREF_HV : 0);
 922             op->op_flags |= OPf_LVAL;
 923         }
 924         break;
 925
 926     case OP_SCOPE:
 927     case OP_LEAVE:
 928     case OP_ENTER:
 929     case OP_LIST:
 930         if (!(op->op_flags & OPf_KIDS))
 931             break;
 932         ref(cLISTOP->op_last, type);
 933         break;
 934     }
 935     return scalar(op);
 936
 937 }
 938
 939 OP *
 940 my(op)
 941 OP *op;
 942 {
 943     OP *kid;
 944     SV *sv;
 945     I32 type;
 946
 947     if (!op)
 948         return op;
 949
 950     type = op->op_type;
 951     if (type == OP_LIST) {
 952         for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
 953             my(kid);
 954     }
 955     else if (type != OP_PADSV &&
 956              type != OP_PADAV &&
 957              type != OP_PADHV &&
 958              type != OP_PUSHMARK)
 959     {
 960         sprintf(tokenbuf, "Can't declare %s in my", op_name[op->op_type]);
 961         yyerror(tokenbuf);
 962         return op;
 963     }
 964     op->op_flags |= OPf_LVAL|OPf_INTRO;
 965     return op;
 966 }
 967
 968 OP *
 969 sawparens(o)
 970 OP *o;
 971 {
 972     if (o)
 973         o->op_flags |= OPf_PARENS;
 974     return o;
 975 }
 976
 977 OP *
 978 bind_match(type, left, right)
 979 I32 type;
 980 OP *left;
 981 OP *right;
 982 {
 983     OP *op;
 984
 985     if (right->op_type == OP_MATCH ||
 986         right->op_type == OP_SUBST ||
 987         right->op_type == OP_TRANS) {
 988         right->op_flags |= OPf_STACKED;
 989         if (right->op_type != OP_MATCH)
 990             left = mod(left, right->op_type);
 991         if (right->op_type == OP_TRANS)
 992             op = newBINOP(OP_NULL, 0, scalar(left), right);
 993         else
 994             op = prepend_elem(right->op_type, scalar(left), right);
 995         if (type == OP_NOT)
 996             return newUNOP(OP_NOT, 0, scalar(op));
 997         return op;
 998     }
 999     else
1000         return bind_match(type, left,
1001                 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1002 }
1003
1004 OP *
1005 invert(op)
1006 OP *op;
1007 {
1008     if (!op)
1009         return op;
1010     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
1011     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(op));
1012 }
1013
1014 OP *
1015 scope(o)
1016 OP *o;
1017 {
1018     if (o) {
1019         if (o->op_flags & OPf_PARENS) {
1020             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1021             o->op_type = OP_LEAVE;
1022             o->op_ppaddr = ppaddr[OP_LEAVE];
1023         }
1024         else {
1025             if (o->op_type == OP_LINESEQ) {
1026                 OP *kid;
1027                 o->op_type = OP_SCOPE;
1028                 o->op_ppaddr = ppaddr[OP_SCOPE];
1029                 kid = ((LISTOP*)o)->op_first;
1030                 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1031                     null(kid);
1032             }
1033             else
1034                 o = newUNOP(OP_SCOPE, 0, o);
1035         }
1036     }
1037     return o;
1038 }
1039
1040 OP *
1041 block_head(o, startp)
1042 OP *o;
1043 OP **startp;
1044 {
1045     if (!o) {
1046         *startp = 0;
1047         return o;
1048     }
1049     o = scope(sawparens(scalarvoid(o)));
1050     curcop = &compiling;
1051     *startp = LINKLIST(o);
1052     o->op_next = 0;
1053     peep(*startp);
1054     return o;
1055 }
1056
1057 OP *
1058 localize(o, lex)
1059 OP *o;
1060 I32 lex;
1061 {
1062     if (o->op_flags & OPf_PARENS)
1063         list(o);
1064     else {
1065         scalar(o);
1066         if (dowarn && bufptr > oldbufptr && bufptr[-1] == ',') {
1067             char *s;
1068             for (s = bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ;
1069             if (*s == ';' || *s == '=' && (s[1] == '@' || s[2] == '@'))
1070                 warn("Parens missing around \"%s\" list", lex ? "my" : "local");
1071         }
1072     }
1073     in_my = FALSE;
1074     if (lex)
1075         return my(o);
1076     else
1077         return mod(o, OP_NULL);         /* a bit kludgey */
1078 }
1079
1080 OP *
1081 jmaybe(o)
1082 OP *o;
1083 {
1084     if (o->op_type == OP_LIST) {
1085         o = convert(OP_JOIN, 0,
1086                 prepend_elem(OP_LIST,
1087                     newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1088                     o));
1089     }
1090     return o;
1091 }
1092
1093 OP *
1094 fold_constants(o)
1095 register OP *o;
1096 {
1097     register OP *curop;
1098     I32 type = o->op_type;
1099     SV *sv;
1100
1101     if (opargs[type] & OA_RETSCALAR)
1102         scalar(o);
1103     if (opargs[type] & OA_TARGET)
1104         o->op_targ = pad_alloc(type, SVs_PADTMP);
1105
1106     if ((opargs[type] & OA_OTHERINT) && (hints & HINT_INTEGER))
1107         o->op_ppaddr = ppaddr[++(o->op_type)];
1108
1109     if (!(opargs[type] & OA_FOLDCONST))
1110         goto nope;
1111
1112     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1113         if (curop->op_type != OP_CONST &&
1114                 curop->op_type != OP_LIST &&
1115                 curop->op_type != OP_SCALAR &&
1116                 curop->op_type != OP_PUSHMARK) {
1117             goto nope;
1118         }
1119     }
1120
1121     curop = LINKLIST(o);
1122     o->op_next = 0;
1123     op = curop;
1124     run();
1125     if (o->op_targ && *stack_sp == PAD_SV(o->op_targ))  /* grab pad temp? */
1126         pad_swipe(o->op_targ);
1127     else if (SvTEMP(*stack_sp)) {                       /* grab mortal temp? */
1128         SvREFCNT_inc(*stack_sp);
1129         SvTEMP_off(*stack_sp);
1130     }
1131     op_free(o);
1132     if (type == OP_RV2GV)
1133         return newGVOP(OP_GV, 0, *(stack_sp--));
1134     else
1135         return newSVOP(OP_CONST, 0, *(stack_sp--));
1136
1137   nope:
1138     if (!(opargs[type] & OA_OTHERINT))
1139         return o;
1140
1141     if (!(hints & HINT_INTEGER)) {
1142         if (!(o->op_flags & OPf_KIDS))
1143             return o;
1144
1145         for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
1146             if (curop->op_type == OP_CONST) {
1147                 if (SvIOK(((SVOP*)curop)->op_sv))
1148                     continue;
1149                 return o;
1150             }
1151             if (opargs[curop->op_type] & OA_RETINTEGER)
1152                 continue;
1153             return o;
1154         }
1155     }
1156
1157     o->op_ppaddr = ppaddr[++(o->op_type)];
1158     return o;
1159 }
1160
1161 OP *
1162 gen_constant_list(o)
1163 register OP *o;
1164 {
1165     register OP *curop;
1166     OP *anonop;
1167     I32 tmpmark;
1168     I32 tmpsp;
1169     I32 oldtmps_floor = tmps_floor;
1170     AV *av;
1171     GV *gv;
1172
1173     tmpmark = stack_sp - stack_base;
1174     anonop = newANONLIST(o);
1175     curop = LINKLIST(anonop);
1176     anonop->op_next = 0;
1177     op = curop;
1178     run();
1179     tmpsp = stack_sp - stack_base;
1180     tmps_floor = oldtmps_floor;
1181     stack_sp = stack_base + tmpmark;
1182
1183     o->op_type = OP_RV2AV;
1184     o->op_ppaddr = ppaddr[OP_RV2AV];
1185     o->op_sibling = 0;
1186     curop = ((UNOP*)o)->op_first;
1187     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, newSVsv(stack_sp[1]));
1188     op_free(curop);
1189     curop = ((UNOP*)anonop)->op_first;
1190     curop = ((UNOP*)curop)->op_first;
1191     curop->op_sibling = 0;
1192     op_free(anonop);
1193     o->op_next = 0;
1194     linklist(o);
1195     return list(o);
1196 }
1197
1198 OP *
1199 convert(type, flags, op)
1200 I32 type;
1201 I32 flags;
1202 OP* op;
1203 {
1204     OP *kid;
1205     OP *last;
1206
1207     if (!op || op->op_type != OP_LIST)
1208         op = newLISTOP(OP_LIST, 0, op, Nullop);
1209
1210     if (!(opargs[type] & OA_MARK))
1211         null(cLISTOP->op_first);
1212
1213     op->op_type = type;
1214     op->op_ppaddr = ppaddr[type];
1215     op->op_flags |= flags;
1216
1217     op = (*check[type])(op);
1218     if (op->op_type != type)
1219         return op;
1220
1221     if (cLISTOP->op_children < 7) {
1222         /* XXX do we really need to do this if we're done appending?? */
1223         for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
1224             last = kid;
1225         cLISTOP->op_last = last;        /* in case check substituted last arg */
1226     }
1227
1228     return fold_constants(op);
1229 }
1230
1231 /* List constructors */
1232
1233 OP *
1234 append_elem(type, first, last)
1235 I32 type;
1236 OP* first;
1237 OP* last;
1238 {
1239     if (!first)
1240         return last;
1241
1242     if (!last)
1243         return first;
1244
1245     if (first->op_type == type) {
1246         if (first->op_flags & OPf_KIDS)
1247             ((LISTOP*)first)->op_last->op_sibling = last;
1248         else {
1249             first->op_flags |= OPf_KIDS;
1250             ((LISTOP*)first)->op_first = last;
1251         }
1252         ((LISTOP*)first)->op_last = last;
1253         ((LISTOP*)first)->op_children++;
1254         return first;
1255     }
1256
1257     return newLISTOP(type, 0, first, last);
1258 }
1259
1260 OP *
1261 append_list(type, first, last)
1262 I32 type;
1263 LISTOP* first;
1264 LISTOP* last;
1265 {
1266     if (!first)
1267         return (OP*)last;
1268
1269     if (!last)
1270         return (OP*)first;
1271
1272     if (first->op_type != type)
1273         return prepend_elem(type, (OP*)first, (OP*)last);
1274
1275     if (last->op_type != type)
1276         return append_elem(type, (OP*)first, (OP*)last);
1277
1278     first->op_last->op_sibling = last->op_first;
1279     first->op_last = last->op_last;
1280     first->op_children += last->op_children;
1281     if (first->op_children)
1282         last->op_flags |= OPf_KIDS;
1283
1284     Safefree(last);
1285     return (OP*)first;
1286 }
1287
1288 OP *
1289 prepend_elem(type, first, last)
1290 I32 type;
1291 OP* first;
1292 OP* last;
1293 {
1294     if (!first)
1295         return last;
1296
1297     if (!last)
1298         return first;
1299
1300     if (last->op_type == type) {
1301         if (type == OP_LIST) {  /* already a PUSHMARK there */
1302             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
1303             ((LISTOP*)last)->op_first->op_sibling = first;
1304         }
1305         else {
1306             if (!(last->op_flags & OPf_KIDS)) {
1307                 ((LISTOP*)last)->op_last = first;
1308                 last->op_flags |= OPf_KIDS;
1309             }
1310             first->op_sibling = ((LISTOP*)last)->op_first;
1311             ((LISTOP*)last)->op_first = first;
1312         }
1313         ((LISTOP*)last)->op_children++;
1314         return last;
1315     }
1316
1317     return newLISTOP(type, 0, first, last);
1318 }
1319
1320 /* Constructors */
1321
1322 OP *
1323 newNULLLIST()
1324 {
1325     return newOP(OP_STUB, 0);
1326 }
1327
1328 OP *
1329 force_list(op)
1330 OP* op;
1331 {
1332     if (!op || op->op_type != OP_LIST)
1333         op = newLISTOP(OP_LIST, 0, op, Nullop);
1334     null(op);
1335     return op;
1336 }
1337
1338 OP *
1339 newLISTOP(type, flags, first, last)
1340 I32 type;
1341 I32 flags;
1342 OP* first;
1343 OP* last;
1344 {
1345     LISTOP *listop;
1346
1347     Newz(1101, listop, 1, LISTOP);
1348
1349     listop->op_type = type;
1350     listop->op_ppaddr = ppaddr[type];
1351     listop->op_children = (first != 0) + (last != 0);
1352     listop->op_flags = flags;
1353
1354     if (!last && first)
1355         last = first;
1356     else if (!first && last)
1357         first = last;
1358     else if (first)
1359         first->op_sibling = last;
1360     listop->op_first = first;
1361     listop->op_last = last;
1362     if (type == OP_LIST) {
1363         OP* pushop;
1364         pushop = newOP(OP_PUSHMARK, 0);
1365         pushop->op_sibling = first;
1366         listop->op_first = pushop;
1367         listop->op_flags |= OPf_KIDS;
1368         if (!last)
1369             listop->op_last = pushop;
1370     }
1371     else if (listop->op_children)
1372         listop->op_flags |= OPf_KIDS;
1373
1374     return (OP*)listop;
1375 }
1376
1377 OP *
1378 newOP(type, flags)
1379 I32 type;
1380 I32 flags;
1381 {
1382     OP *op;
1383     Newz(1101, op, 1, OP);
1384     op->op_type = type;
1385     op->op_ppaddr = ppaddr[type];
1386     op->op_flags = flags;
1387
1388     op->op_next = op;
1389     /* op->op_private = 0; */
1390     if (opargs[type] & OA_RETSCALAR)
1391         scalar(op);
1392     if (opargs[type] & OA_TARGET)
1393         op->op_targ = pad_alloc(type, SVs_PADTMP);
1394     return (*check[type])(op);
1395 }
1396
1397 OP *
1398 newUNOP(type, flags, first)
1399 I32 type;
1400 I32 flags;
1401 OP* first;
1402 {
1403     UNOP *unop;
1404
1405     if (!first)
1406         first = newOP(OP_STUB, 0);
1407     if (opargs[type] & OA_MARK)
1408         first = force_list(first);
1409     else if (first->op_type == OP_LIST)
1410         unlist(first);
1411
1412     Newz(1101, unop, 1, UNOP);
1413     unop->op_type = type;
1414     unop->op_ppaddr = ppaddr[type];
1415     unop->op_first = first;
1416     unop->op_flags = flags | OPf_KIDS;
1417     unop->op_private = 1;
1418
1419     unop = (UNOP*)(*check[type])((OP*)unop);
1420     if (unop->op_next)
1421         return (OP*)unop;
1422
1423     return fold_constants(unop);
1424 }
1425
1426 OP *
1427 newBINOP(type, flags, first, last)
1428 I32 type;
1429 I32 flags;
1430 OP* first;
1431 OP* last;
1432 {
1433     BINOP *binop;
1434     Newz(1101, binop, 1, BINOP);
1435
1436     if (!first)
1437         first = newOP(OP_NULL, 0);
1438
1439     binop->op_type = type;
1440     binop->op_ppaddr = ppaddr[type];
1441     binop->op_first = first;
1442     binop->op_flags = flags | OPf_KIDS;
1443     if (!last) {
1444         last = first;
1445         binop->op_private = 1;
1446     }
1447     else {
1448         binop->op_private = 2;
1449         first->op_sibling = last;
1450     }
1451
1452     binop = (BINOP*)(*check[type])((OP*)binop);
1453     if (binop->op_next)
1454         return (OP*)binop;
1455
1456     binop->op_last = last = binop->op_first->op_sibling;
1457
1458     return fold_constants(binop);
1459 }
1460
1461 OP *
1462 pmtrans(op, expr, repl)
1463 OP *op;
1464 OP *expr;
1465 OP *repl;
1466 {
1467     PMOP *pm = (PMOP*)op;
1468     SV *tstr = ((SVOP*)expr)->op_sv;
1469     SV *rstr = ((SVOP*)repl)->op_sv;
1470     STRLEN tlen;
1471     STRLEN rlen;
1472     register char *t = SvPV(tstr, tlen);
1473     register char *r = SvPV(rstr, rlen);
1474     register I32 i;
1475     register I32 j;
1476     I32 squash;
1477     I32 delete;
1478     I32 complement;
1479     register short *tbl;
1480
1481     tbl = (short*)cPVOP->op_pv;
1482     complement  = op->op_private & OPpTRANS_COMPLEMENT;
1483     delete      = op->op_private & OPpTRANS_DELETE;
1484     squash      = op->op_private & OPpTRANS_SQUASH;
1485
1486     if (complement) {
1487         Zero(tbl, 256, short);
1488         for (i = 0; i < tlen; i++)
1489             tbl[t[i] & 0377] = -1;
1490         for (i = 0, j = 0; i < 256; i++) {
1491             if (!tbl[i]) {
1492                 if (j >= rlen) {
1493                     if (delete)
1494                         tbl[i] = -2;
1495                     else if (rlen)
1496                         tbl[i] = r[j-1] & 0377;
1497                     else
1498                         tbl[i] = i;
1499                 }
1500                 else
1501                     tbl[i] = r[j++] & 0377;
1502             }
1503         }
1504     }
1505     else {
1506         if (!rlen && !delete) {
1507             r = t; rlen = tlen;
1508         }
1509         for (i = 0; i < 256; i++)
1510             tbl[i] = -1;
1511         for (i = 0, j = 0; i < tlen; i++,j++) {
1512             if (j >= rlen) {
1513                 if (delete) {
1514                     if (tbl[t[i] & 0377] == -1)
1515                         tbl[t[i] & 0377] = -2;
1516                     continue;
1517                 }
1518                 --j;
1519             }
1520             if (tbl[t[i] & 0377] == -1)
1521                 tbl[t[i] & 0377] = r[j] & 0377;
1522         }
1523     }
1524     op_free(expr);
1525     op_free(repl);
1526
1527     return op;
1528 }
1529
1530 OP *
1531 newPMOP(type, flags)
1532 I32 type;
1533 I32 flags;
1534 {
1535     PMOP *pmop;
1536
1537     Newz(1101, pmop, 1, PMOP);
1538     pmop->op_type = type;
1539     pmop->op_ppaddr = ppaddr[type];
1540     pmop->op_flags = flags;
1541     pmop->op_private = 0;
1542
1543     /* link into pm list */
1544     if (type != OP_TRANS) {
1545         pmop->op_pmnext = HvPMROOT(curstash);
1546         HvPMROOT(curstash) = pmop;
1547     }
1548
1549     return (OP*)pmop;
1550 }
1551
1552 OP *
1553 pmruntime(op, expr, repl)
1554 OP *op;
1555 OP *expr;
1556 OP *repl;
1557 {
1558     PMOP *pm;
1559     LOGOP *rcop;
1560
1561     if (op->op_type == OP_TRANS)
1562         return pmtrans(op, expr, repl);
1563
1564     pm = (PMOP*)op;
1565
1566     if (expr->op_type == OP_CONST) {
1567         STRLEN plen;
1568         SV *pat = ((SVOP*)expr)->op_sv;
1569         char *p = SvPV(pat, plen);
1570         if ((op->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
1571             sv_setpvn(pat, "\\s+", 3);
1572             p = SvPV(pat, plen);
1573             pm->op_pmflags |= PMf_SKIPWHITE;
1574         }
1575         scan_prefix(pm, p, plen);
1576         if (pm->op_pmshort && (pm->op_pmflags & PMf_SCANFIRST))
1577             fbm_compile(pm->op_pmshort, pm->op_pmflags & PMf_FOLD);
1578         pm->op_pmregexp = regcomp(p, p + plen, pm->op_pmflags & PMf_FOLD);
1579         if (strEQ("\\s+", pm->op_pmregexp->precomp))
1580             pm->op_pmflags |= PMf_WHITE;
1581         hoistmust(pm);
1582         op_free(expr);
1583     }
1584     else {
1585         if (pm->op_pmflags & PMf_KEEP)
1586             expr = newUNOP(OP_REGCMAYBE,0,expr);
1587
1588         Newz(1101, rcop, 1, LOGOP);
1589         rcop->op_type = OP_REGCOMP;
1590         rcop->op_ppaddr = ppaddr[OP_REGCOMP];
1591         rcop->op_first = scalar(expr);
1592         rcop->op_flags |= OPf_KIDS;
1593         rcop->op_private = 1;
1594         rcop->op_other = op;
1595
1596         /* establish postfix order */
1597         if (pm->op_pmflags & PMf_KEEP) {
1598             LINKLIST(expr);
1599             rcop->op_next = expr;
1600             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
1601         }
1602         else {
1603             rcop->op_next = LINKLIST(expr);
1604             expr->op_next = (OP*)rcop;
1605         }
1606
1607         prepend_elem(op->op_type, scalar((OP*)rcop), op);
1608     }
1609
1610     if (repl) {
1611         if (repl->op_type == OP_CONST) {
1612             pm->op_pmflags |= PMf_CONST;
1613             prepend_elem(op->op_type, scalar(repl), op);
1614         }
1615         else {
1616             OP *curop;
1617             OP *lastop = 0;
1618             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
1619                 if (opargs[curop->op_type] & OA_DANGEROUS) {
1620                     if (curop->op_type == OP_GV) {
1621                         GV *gv = ((GVOP*)curop)->op_gv;
1622                         if (strchr("&`'123456789+", *GvENAME(gv)))
1623                             break;
1624                     }
1625                     else if (curop->op_type == OP_RV2CV)
1626                         break;
1627                     else if (curop->op_type == OP_RV2SV ||
1628                              curop->op_type == OP_RV2AV ||
1629                              curop->op_type == OP_RV2HV ||
1630                              curop->op_type == OP_RV2GV) {
1631                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
1632                             break;
1633                     }
1634                     else
1635                         break;
1636                 }
1637                 lastop = curop;
1638             }
1639             if (curop == repl) {
1640                 pm->op_pmflags |= PMf_CONST;    /* const for long enough */
1641                 prepend_elem(op->op_type, scalar(repl), op);
1642             }
1643             else {
1644                 Newz(1101, rcop, 1, LOGOP);
1645                 rcop->op_type = OP_SUBSTCONT;
1646                 rcop->op_ppaddr = ppaddr[OP_SUBSTCONT];
1647                 rcop->op_first = scalar(repl);
1648                 rcop->op_flags |= OPf_KIDS;
1649                 rcop->op_private = 1;
1650                 rcop->op_other = op;
1651
1652                 /* establish postfix order */
1653                 rcop->op_next = LINKLIST(repl);
1654                 repl->op_next = (OP*)rcop;
1655
1656                 pm->op_pmreplroot = scalar((OP*)rcop);
1657                 pm->op_pmreplstart = LINKLIST(rcop);
1658                 rcop->op_next = 0;
1659             }
1660         }
1661     }
1662
1663     return (OP*)pm;
1664 }
1665
1666 OP *
1667 newSVOP(type, flags, sv)
1668 I32 type;
1669 I32 flags;
1670 SV *sv;
1671 {
1672     SVOP *svop;
1673     Newz(1101, svop, 1, SVOP);
1674     svop->op_type = type;
1675     svop->op_ppaddr = ppaddr[type];
1676     svop->op_sv = sv;
1677     svop->op_next = (OP*)svop;
1678     svop->op_flags = flags;
1679     if (opargs[type] & OA_RETSCALAR)
1680         scalar((OP*)svop);
1681     if (opargs[type] & OA_TARGET)
1682         svop->op_targ = pad_alloc(type, SVs_PADTMP);
1683     return (*check[type])((OP*)svop);
1684 }
1685
1686 OP *
1687 newGVOP(type, flags, gv)
1688 I32 type;
1689 I32 flags;
1690 GV *gv;
1691 {
1692     GVOP *gvop;
1693     Newz(1101, gvop, 1, GVOP);
1694     gvop->op_type = type;
1695     gvop->op_ppaddr = ppaddr[type];
1696     gvop->op_gv = (GV*)SvREFCNT_inc(gv);
1697     gvop->op_next = (OP*)gvop;
1698     gvop->op_flags = flags;
1699     if (opargs[type] & OA_RETSCALAR)
1700         scalar((OP*)gvop);
1701     if (opargs[type] & OA_TARGET)
1702         gvop->op_targ = pad_alloc(type, SVs_PADTMP);
1703     return (*check[type])((OP*)gvop);
1704 }
1705
1706 OP *
1707 newPVOP(type, flags, pv)
1708 I32 type;
1709 I32 flags;
1710 char *pv;
1711 {
1712     PVOP *pvop;
1713     Newz(1101, pvop, 1, PVOP);
1714     pvop->op_type = type;
1715     pvop->op_ppaddr = ppaddr[type];
1716     pvop->op_pv = pv;
1717     pvop->op_next = (OP*)pvop;
1718     pvop->op_flags = flags;
1719     if (opargs[type] & OA_RETSCALAR)
1720         scalar((OP*)pvop);
1721     if (opargs[type] & OA_TARGET)
1722         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
1723     return (*check[type])((OP*)pvop);
1724 }
1725
1726 OP *
1727 newCVOP(type, flags, cv, cont)
1728 I32 type;
1729 I32 flags;
1730 CV *cv;
1731 OP *cont;
1732 {
1733     CVOP *cvop;
1734     Newz(1101, cvop, 1, CVOP);
1735     cvop->op_type = type;
1736     cvop->op_ppaddr = ppaddr[type];
1737     cvop->op_cv = cv;
1738     cvop->op_cont = cont;
1739     cvop->op_next = (OP*)cvop;
1740     cvop->op_flags = flags;
1741     if (opargs[type] & OA_RETSCALAR)
1742         scalar((OP*)cvop);
1743     if (opargs[type] & OA_TARGET)
1744         cvop->op_targ = pad_alloc(type, SVs_PADTMP);
1745     return (*check[type])((OP*)cvop);
1746 }
1747
1748 void
1749 package(op)
1750 OP *op;
1751 {
1752     SV *sv;
1753
1754     save_hptr(&curstash);
1755     save_item(curstname);
1756     if (op) {
1757         STRLEN len;
1758         char *name;
1759         sv = cSVOP->op_sv;
1760         curstash = fetch_stash(sv,TRUE);
1761         name = SvPV(sv, len);
1762         sv_setpvn(curstname, name, len);
1763         op_free(op);
1764     }
1765     else {
1766         sv_setpv(curstname,"<none>");
1767         curstash = Nullhv;
1768     }
1769     copline = NOLINE;
1770     expect = XSTATE;
1771 }
1772
1773 void
1774 hint(aver, id, arg)
1775 int aver;
1776 OP *id;
1777 OP *arg;
1778 {
1779     SV *sv;
1780     U32 bits = 0;
1781     SV **sp = 0;
1782     SV **mark = 0;
1783
1784     if (arg) {
1785         OP* curop = LINKLIST(arg);
1786         arg->op_next = 0;
1787         op = curop;
1788         run();
1789         sp = stack_sp;
1790         mark = stack_base + POPMARK;
1791         stack_sp = mark;        /* Might as well reset sp now. */
1792     }
1793     if (id) {
1794         STRLEN len;
1795         char *name;
1796         sv = ((SVOP*)id)->op_sv;
1797         name = SvPV(sv, len);
1798
1799         if (strEQ(name, "integer"))
1800             bits = HINT_INTEGER;
1801         else if (strEQ(name, "strict")) {
1802             if (arg) {
1803                 while (++mark <= sp) {
1804                     if (strEQ(SvPV(*mark,na), "refs"))
1805                         bits |= HINT_STRICT_REFS;
1806                     else if (strEQ(SvPV(*mark,na), "subs"))
1807                         bits |= HINT_STRICT_SUBS;
1808                     else if (strEQ(SvPV(*mark,na), "vars"))
1809                         bits |= HINT_STRICT_VARS;
1810                 }
1811             }
1812             else
1813                 bits = HINT_STRICT_REFS|HINT_STRICT_SUBS|HINT_STRICT_VARS;
1814         }
1815
1816         if (aver)
1817             hints |= bits;
1818         else
1819             hints &= ~bits;
1820
1821         op_free(id);
1822     }
1823     if (arg)
1824         op_free(arg);
1825     copline = NOLINE;
1826     expect = XSTATE;
1827 }
1828
1829 HV*
1830 fetch_stash(sv,create)
1831 SV *sv;
1832 I32 create;
1833 {
1834     char tmpbuf[256];
1835     HV *stash;
1836     GV *tmpgv;
1837     char *name = SvPV(sv, na);
1838     sprintf(tmpbuf,"%s::",name);
1839     tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV);
1840     if (!tmpgv)
1841         return 0;
1842     if (!GvHV(tmpgv))
1843         GvHV(tmpgv) = newHV();
1844     stash = GvHV(tmpgv);
1845     if (!HvNAME(stash))
1846         HvNAME(stash) = savestr(name);
1847     return stash;
1848 }
1849
1850 OP *
1851 newSLICEOP(flags, subscript, listval)
1852 I32 flags;
1853 OP *subscript;
1854 OP *listval;
1855 {
1856     return newBINOP(OP_LSLICE, flags,
1857             list(force_list(subscript)),
1858             list(force_list(listval)) );
1859 }
1860
1861 static I32
1862 list_assignment(op)
1863 register OP *op;
1864 {
1865     if (!op)
1866         return TRUE;
1867
1868     if (op->op_type == OP_NULL && op->op_flags & OPf_KIDS)
1869         op = cUNOP->op_first;
1870
1871     if (op->op_type == OP_COND_EXPR) {
1872         I32 t = list_assignment(cCONDOP->op_first->op_sibling);
1873         I32 f = list_assignment(cCONDOP->op_first->op_sibling->op_sibling);
1874
1875         if (t && f)
1876             return TRUE;
1877         if (t || f)
1878             yyerror("Assignment to both a list and a scalar");
1879         return FALSE;
1880     }
1881
1882     if (op->op_type == OP_LIST || op->op_flags & OPf_PARENS ||
1883         op->op_type == OP_RV2AV || op->op_type == OP_RV2HV ||
1884         op->op_type == OP_ASLICE || op->op_type == OP_HSLICE)
1885         return TRUE;
1886
1887     if (op->op_type == OP_PADAV || op->op_type == OP_PADHV)
1888         return TRUE;
1889
1890     if (op->op_type == OP_RV2SV)
1891         return FALSE;
1892
1893     return FALSE;
1894 }
1895
1896 OP *
1897 newASSIGNOP(flags, left, right)
1898 I32 flags;
1899 OP *left;
1900 OP *right;
1901 {
1902     OP *op;
1903
1904     if (list_assignment(left)) {
1905         modcount = 0;
1906         left = mod(left, OP_AASSIGN);
1907         if (right && right->op_type == OP_SPLIT) {
1908             if ((op = ((LISTOP*)right)->op_first) && op->op_type == OP_PUSHRE) {
1909                 PMOP *pm = (PMOP*)op;
1910                 if (left->op_type == OP_RV2AV) {
1911                     op = ((UNOP*)left)->op_first;
1912                     if (op->op_type == OP_GV && !pm->op_pmreplroot) {
1913                         pm->op_pmreplroot = (OP*)((GVOP*)op)->op_gv;
1914                         pm->op_pmflags |= PMf_ONCE;
1915                         op_free(left);
1916                         return right;
1917                     }
1918                 }
1919                 else {
1920                     if (modcount < 10000) {
1921                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
1922                         if (SvIVX(sv) == 0)
1923                             sv_setiv(sv, modcount+1);
1924                     }
1925                 }
1926             }
1927         }
1928         op = newBINOP(OP_AASSIGN, flags,
1929                 list(force_list(right)),
1930                 list(force_list(left)) );
1931         op->op_private = 0;
1932         if (!(left->op_flags & OPf_INTRO)) {
1933             static int generation = 0;
1934             OP *curop;
1935             OP *lastop = op;
1936             generation++;
1937             for (curop = LINKLIST(op); curop != op; curop = LINKLIST(curop)) {
1938                 if (opargs[curop->op_type] & OA_DANGEROUS) {
1939                     if (curop->op_type == OP_GV) {
1940                         GV *gv = ((GVOP*)curop)->op_gv;
1941                         if (gv == defgv || SvCUR(gv) == generation)
1942                             break;
1943                         SvCUR(gv) = generation;
1944                     }
1945                     else if (curop->op_type == OP_RV2CV)
1946                         break;
1947                     else if (curop->op_type == OP_RV2SV ||
1948                              curop->op_type == OP_RV2AV ||
1949                              curop->op_type == OP_RV2HV ||
1950                              curop->op_type == OP_RV2GV) {
1951                         if (lastop->op_type != OP_GV)   /* funny deref? */
1952                             break;
1953                     }
1954                     else
1955                         break;
1956                 }
1957                 lastop = curop;
1958             }
1959             if (curop != op)
1960                 op->op_private = OPpASSIGN_COMMON;
1961         }
1962         return op;
1963     }
1964     if (!right)
1965         right = newOP(OP_UNDEF, 0);
1966     if (right->op_type == OP_READLINE) {
1967         right->op_flags |= OPf_STACKED;
1968         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
1969     }
1970     else
1971         op = newBINOP(OP_SASSIGN, flags,
1972             scalar(right), mod(scalar(left), OP_SASSIGN) );
1973     return op;
1974 }
1975
1976 OP *
1977 newSTATEOP(flags, label, op)
1978 I32 flags;
1979 char *label;
1980 OP *op;
1981 {
1982     register COP *cop;
1983
1984     /* Introduce my variables. */
1985     if (min_intro_pending) {
1986         SV **svp = AvARRAY(comppad_name);
1987         I32 i;
1988         SV *sv;
1989         for (i = min_intro_pending; i <= max_intro_pending; i++) {
1990             if (sv = svp[i])
1991                 SvIVX(sv) = 999999999;  /* Don't know scope end yet. */
1992         }
1993         min_intro_pending = 0;
1994         comppad_name_fill = max_intro_pending;  /* Needn't search higher */
1995     }
1996
1997     Newz(1101, cop, 1, COP);
1998     if (perldb && curcop->cop_line && curstash != debstash) {
1999         cop->op_type = OP_DBSTATE;
2000         cop->op_ppaddr = ppaddr[ OP_DBSTATE ];
2001     }
2002     else {
2003         cop->op_type = OP_NEXTSTATE;
2004         cop->op_ppaddr = ppaddr[ OP_NEXTSTATE ];
2005     }
2006     cop->op_flags = flags;
2007     cop->op_private = 0;
2008     cop->op_next = (OP*)cop;
2009
2010     if (label) {
2011         cop->cop_label = label;
2012         hints |= HINT_BLOCK_SCOPE;
2013     }
2014     cop->cop_seq = cop_seqmax++;
2015
2016     if (copline == NOLINE)
2017         cop->cop_line = curcop->cop_line;
2018     else {
2019         cop->cop_line = copline;
2020         copline = NOLINE;
2021     }
2022     cop->cop_filegv = SvREFCNT_inc(curcop->cop_filegv);
2023     cop->cop_stash = curstash;
2024
2025     if (perldb && curstash != debstash) {
2026         SV **svp = av_fetch(GvAV(curcop->cop_filegv),(I32)cop->cop_line, FALSE);
2027         if (svp && *svp != &sv_undef && !SvIOK(*svp)) {
2028             SvIVX(*svp) = 1;
2029             SvIOK_on(*svp);
2030             SvSTASH(*svp) = (HV*)cop;
2031         }
2032     }
2033
2034     return prepend_elem(OP_LINESEQ, (OP*)cop, op);
2035 }
2036
2037 OP *
2038 newLOGOP(type, flags, first, other)
2039 I32 type;
2040 I32 flags;
2041 OP* first;
2042 OP* other;
2043 {
2044     LOGOP *logop;
2045     OP *op;
2046
2047     scalarboolean(first);
2048     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
2049     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
2050         if (type == OP_AND || type == OP_OR) {
2051             if (type == OP_AND)
2052                 type = OP_OR;
2053             else
2054                 type = OP_AND;
2055             op = first;
2056             first = cUNOP->op_first;
2057             if (op->op_next)
2058                 first->op_next = op->op_next;
2059             cUNOP->op_first = Nullop;
2060             op_free(op);
2061         }
2062     }
2063     if (first->op_type == OP_CONST) {
2064         if (dowarn && (first->op_private & OPpCONST_BARE))
2065             warn("Probable precedence problem on %s", op_name[type]);
2066         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
2067             op_free(first);
2068             return other;
2069         }
2070         else {
2071             op_free(other);
2072             return first;
2073         }
2074     }
2075     else if (first->op_type == OP_WANTARRAY) {
2076         if (type == OP_AND)
2077             list(other);
2078         else
2079             scalar(other);
2080     }
2081
2082     if (!other)
2083         return first;
2084
2085     Newz(1101, logop, 1, LOGOP);
2086
2087     logop->op_type = type;
2088     logop->op_ppaddr = ppaddr[type];
2089     logop->op_first = first;
2090     logop->op_flags = flags | OPf_KIDS;
2091     logop->op_other = LINKLIST(other);
2092     logop->op_private = 1;
2093
2094     /* establish postfix order */
2095     logop->op_next = LINKLIST(first);
2096     first->op_next = (OP*)logop;
2097     first->op_sibling = other;
2098
2099     op = newUNOP(OP_NULL, 0, (OP*)logop);
2100     other->op_next = op;
2101
2102     return op;
2103 }
2104
2105 OP *
2106 newCONDOP(flags, first, true, false)
2107 I32 flags;
2108 OP* first;
2109 OP* true;
2110 OP* false;
2111 {
2112     CONDOP *condop;
2113     OP *op;
2114
2115     if (!false)
2116         return newLOGOP(OP_AND, 0, first, true);
2117     if (!true)
2118         return newLOGOP(OP_OR, 0, first, false);
2119
2120     scalarboolean(first);
2121     if (first->op_type == OP_CONST) {
2122         if (SvTRUE(((SVOP*)first)->op_sv)) {
2123             op_free(first);
2124             op_free(false);
2125             return true;
2126         }
2127         else {
2128             op_free(first);
2129             op_free(true);
2130             return false;
2131         }
2132     }
2133     else if (first->op_type == OP_WANTARRAY) {
2134         list(true);
2135         scalar(false);
2136     }
2137     Newz(1101, condop, 1, CONDOP);
2138
2139     condop->op_type = OP_COND_EXPR;
2140     condop->op_ppaddr = ppaddr[OP_COND_EXPR];
2141     condop->op_first = first;
2142     condop->op_flags = flags | OPf_KIDS;
2143     condop->op_true = LINKLIST(true);
2144     condop->op_false = LINKLIST(false);
2145     condop->op_private = 1;
2146
2147     /* establish postfix order */
2148     condop->op_next = LINKLIST(first);
2149     first->op_next = (OP*)condop;
2150
2151     first->op_sibling = true;
2152     true->op_sibling = false;
2153     op = newUNOP(OP_NULL, 0, (OP*)condop);
2154
2155     true->op_next = op;
2156     false->op_next = op;
2157
2158     return op;
2159 }
2160
2161 OP *
2162 newRANGE(flags, left, right)
2163 I32 flags;
2164 OP *left;
2165 OP *right;
2166 {
2167     CONDOP *condop;
2168     OP *flip;
2169     OP *flop;
2170     OP *op;
2171
2172     Newz(1101, condop, 1, CONDOP);
2173
2174     condop->op_type = OP_RANGE;
2175     condop->op_ppaddr = ppaddr[OP_RANGE];
2176     condop->op_first = left;
2177     condop->op_flags = OPf_KIDS;
2178     condop->op_true = LINKLIST(left);
2179     condop->op_false = LINKLIST(right);
2180     condop->op_private = 1;
2181
2182     left->op_sibling = right;
2183
2184     condop->op_next = (OP*)condop;
2185     flip = newUNOP(OP_FLIP, flags, (OP*)condop);
2186     flop = newUNOP(OP_FLOP, 0, flip);
2187     op = newUNOP(OP_NULL, 0, flop);
2188     linklist(flop);
2189
2190     left->op_next = flip;
2191     right->op_next = flop;
2192
2193     condop->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
2194     sv_upgrade(PAD_SV(condop->op_targ), SVt_PVNV);
2195     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
2196     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
2197
2198     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
2199     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
2200
2201     flip->op_next = op;
2202     if (!flip->op_private || !flop->op_private)
2203         linklist(op);           /* blow off optimizer unless constant */
2204
2205     return op;
2206 }
2207
2208 OP *
2209 newLOOPOP(flags, debuggable, expr, block)
2210 I32 flags;
2211 I32 debuggable;
2212 OP *expr;
2213 OP *block;
2214 {
2215     OP* listop;
2216     OP* op;
2217     int once = block && block->op_flags & OPf_SPECIAL &&
2218       (block->op_type == OP_ENTERSUBR || block->op_type == OP_NULL);
2219
2220     if (expr) {
2221         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
2222             return block;       /* do {} while 0 does once */
2223         else if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB)
2224             expr = newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), expr);
2225     }
2226
2227     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
2228     op = newLOGOP(OP_AND, 0, expr, listop);
2229
2230     ((LISTOP*)listop)->op_last->op_next = LINKLIST(op);
2231
2232     if (once && op != listop)
2233         op->op_next = ((LOGOP*)cUNOP->op_first)->op_other;
2234
2235     op->op_flags |= flags;
2236     return scope(op);
2237 }
2238
2239 OP *
2240 newWHILEOP(flags, debuggable, loop, expr, block, cont)
2241 I32 flags;
2242 I32 debuggable;
2243 LOOP *loop;
2244 OP *expr;
2245 OP *block;
2246 OP *cont;
2247 {
2248     OP *redo;
2249     OP *next = 0;
2250     OP *listop;
2251     OP *op;
2252     OP *condop;
2253
2254     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB))
2255         expr = newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), expr);
2256
2257     if (!block)
2258         block = newOP(OP_NULL, 0);
2259
2260     if (cont)
2261         next = LINKLIST(cont);
2262     if (expr)
2263         cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0));
2264
2265     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
2266     redo = LINKLIST(listop);
2267
2268     if (expr) {
2269         op = newLOGOP(OP_AND, 0, expr, scalar(listop));
2270         if (op == expr && op->op_type == OP_CONST && !SvTRUE(cSVOP->op_sv)) {
2271             op_free(expr);              /* oops, it's a while (0) */
2272             op_free((OP*)loop);
2273             return Nullop;              /* (listop already freed by newLOGOP) */
2274         }
2275         ((LISTOP*)listop)->op_last->op_next = condop =
2276             (op == listop ? redo : LINKLIST(op));
2277         if (!next)
2278             next = condop;
2279     }
2280     else
2281         op = listop;
2282
2283     if (!loop) {
2284         Newz(1101,loop,1,LOOP);
2285         loop->op_type = OP_ENTERLOOP;
2286         loop->op_ppaddr = ppaddr[OP_ENTERLOOP];
2287         loop->op_private = 0;
2288         loop->op_next = (OP*)loop;
2289     }
2290
2291     op = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, op);
2292
2293     loop->op_redoop = redo;
2294     loop->op_lastop = op;
2295
2296     if (next)
2297         loop->op_nextop = next;
2298     else
2299         loop->op_nextop = op;
2300
2301     op->op_flags |= flags;
2302     return op;
2303 }
2304
2305 OP *
2306 #ifndef STANDARD_C
2307 newFOROP(flags,label,forline,sv,expr,block,cont)
2308 I32 flags;
2309 char *label;
2310 line_t forline;
2311 OP* sv;
2312 OP* expr;
2313 OP*block;
2314 OP*cont;
2315 #else
2316 newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
2317 #endif /* STANDARD_C */
2318 {
2319     LOOP *loop;
2320     int padoff = 0;
2321
2322     copline = forline;
2323     if (sv) {
2324         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
2325             OP *op = sv;
2326             sv = cUNOP->op_first;
2327             sv->op_next = sv;
2328             cUNOP->op_first = Nullop;
2329             op_free(op);
2330         }
2331         else if (sv->op_type == OP_PADSV) { /* private variable */
2332             padoff = sv->op_targ;
2333             op_free(sv);
2334             sv = Nullop;
2335         }
2336         else
2337             croak("Can't use %s for loop variable", op_name[sv->op_type]);
2338     }
2339     else {
2340         sv = newGVOP(OP_GV, 0, defgv);
2341     }
2342     loop = (LOOP*)list(convert(OP_ENTERITER, 0,
2343         append_elem(OP_LIST, force_list(expr), scalar(sv))));
2344     assert(!loop->op_next);
2345     Renew(loop, 1, LOOP);
2346     loop->op_targ = padoff;
2347     return newSTATEOP(0, label, newWHILEOP(flags, 1, loop,
2348         newOP(OP_ITER, 0), block, cont));
2349 }
2350
2351 OP*
2352 newLOOPEX(type, label)
2353 I32 type;
2354 OP* label;
2355 {
2356     OP *op;
2357     if (type != OP_GOTO || label->op_type == OP_CONST) {
2358         op = newPVOP(type, 0, savestr(SvPVx(((SVOP*)label)->op_sv, na)));
2359         op_free(label);
2360     }
2361     else {
2362         if (label->op_type == OP_ENTERSUBR)
2363             label = newUNOP(OP_REFGEN, 0, ref(label, OP_REFGEN));
2364         op = newUNOP(type, OPf_STACKED, label);
2365     }
2366     hints |= HINT_BLOCK_SCOPE;
2367     return op;
2368 }
2369
2370 void
2371 cv_undef(cv)
2372 CV *cv;
2373 {
2374     if (!CvUSERSUB(cv) && CvROOT(cv)) {
2375         ENTER;
2376         if (CvPADLIST(cv)) {
2377             SV** svp = av_fetch(CvPADLIST(cv), 0, FALSE);
2378             if (svp) {
2379                 SAVESPTR(comppad);
2380                 SAVESPTR(curpad);
2381                 comppad = (AV*)*svp;    /* Need same context we had compiling */
2382                 curpad = AvARRAY(comppad);
2383             }
2384         }
2385         op_free(CvROOT(cv));
2386         CvROOT(cv) = Nullop;
2387         if (CvDEPTH(cv))
2388             warn("Deleting active subroutine");         /* XXX */
2389         if (CvPADLIST(cv)) {
2390             I32 i = AvFILL(CvPADLIST(cv));
2391             while (i > 0) {
2392                 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
2393                 if (svp)
2394                     sv_free(*svp);
2395             }
2396             sv_free(CvPADLIST(cv));
2397         }
2398         SvREFCNT_dec(CvGV(cv));
2399         LEAVE;
2400     }
2401 }
2402
2403 void
2404 newSUB(floor,op,block)
2405 I32 floor;
2406 OP *op;
2407 OP *block;
2408 {
2409     register CV *cv;
2410     char *name = SvPVx(cSVOP->op_sv, na);
2411     GV *gv = gv_fetchpv(name,2, SVt_PVCV);
2412     AV* av;
2413     char *s;
2414
2415     sub_generation++;
2416     if ((cv = GvCV(gv)) && !GvCVGEN(gv)) {
2417         if (CvDEPTH(cv))
2418             CvDELETED(cv) = TRUE;       /* probably an autoloader */
2419         else {
2420             if (dowarn && CvROOT(cv)) {
2421                 line_t oldline = curcop->cop_line;
2422
2423                 curcop->cop_line = copline;
2424                 warn("Subroutine %s redefined",name);
2425                 curcop->cop_line = oldline;
2426             }
2427             SvREFCNT_dec(cv);
2428         }
2429     }
2430     Newz(101,cv,1,CV);
2431     sv_upgrade(cv, SVt_PVCV);
2432     SvREFCNT(cv) = 1;
2433     GvCV(gv) = cv;
2434     GvCVGEN(gv) = 0;
2435     CvFILEGV(cv) = curcop->cop_filegv;
2436     CvGV(cv) = SvREFCNT_inc(gv);
2437     CvSTASH(cv) = curstash;
2438
2439     av = newAV();
2440     av_store(av, 0, Nullsv);
2441     av_store(comppad, 0, (SV*)av);
2442     SvOK_on(av);
2443     AvREAL_off(av);
2444
2445     av = newAV();
2446     AvREAL_off(av);
2447     if (AvFILL(comppad_name) < AvFILL(comppad))
2448         av_store(comppad_name, AvFILL(comppad), Nullsv);
2449     av_store(av, 0, (SV*)comppad_name);
2450     av_store(av, 1, (SV*)comppad);
2451     AvFILL(av) = 1;
2452     CvPADLIST(cv) = av;
2453     comppad_name = newAV();
2454
2455     if (!block) {
2456         CvROOT(cv) = 0;
2457         op_free(op);
2458         copline = NOLINE;
2459         LEAVE_SCOPE(floor);
2460         return;
2461     }
2462     CvROOT(cv) = newUNOP(OP_LEAVESUBR, 0, scalarseq(block));
2463     CvSTART(cv) = LINKLIST(CvROOT(cv));
2464     CvROOT(cv)->op_next = 0;
2465     peep(CvSTART(cv));
2466     CvDELETED(cv) = FALSE;
2467     if (s = strrchr(name,':'))
2468         s++;
2469     else
2470         s = name;
2471     if (strEQ(s, "BEGIN")) {
2472         line_t oldline = compiling.cop_line;
2473
2474         ENTER;
2475         SAVESPTR(compiling.cop_filegv);
2476         SAVEI32(perldb);
2477         if (!beginav)
2478             beginav = newAV();
2479         av_push(beginav, (SV *)cv);
2480         DEBUG_x( dump_sub(gv) );
2481         rs = nrs;
2482         rslen = nrslen;
2483         rschar = nrschar;
2484         rspara = (nrslen == 2);
2485         GvCV(gv) = 0;
2486         calllist(beginav);
2487         rs = "\n";
2488         rslen = 1;
2489         rschar = '\n';
2490         rspara = 0;
2491         curcop = &compiling;
2492         curcop->cop_line = oldline;     /* might have recursed to yylex */
2493         LEAVE;
2494     }
2495     else if (strEQ(s, "END")) {
2496         if (!endav)
2497             endav = newAV();
2498         av_unshift(endav, 1);
2499         av_store(endav, 0, SvREFCNT_inc(cv));
2500     }
2501     if (perldb && curstash != debstash) {
2502         SV *sv;
2503         SV *tmpstr = sv_newmortal();
2504
2505         sprintf(buf,"%s:%ld",SvPVX(GvSV(curcop->cop_filegv)), subline);
2506         sv = newSVpv(buf,0);
2507         sv_catpv(sv,"-");
2508         sprintf(buf,"%ld",(long)curcop->cop_line);
2509         sv_catpv(sv,buf);
2510         gv_efullname(tmpstr,gv);
2511         hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
2512     }
2513     op_free(op);
2514     copline = NOLINE;
2515     LEAVE_SCOPE(floor);
2516 }
2517
2518 void
2519 newXSUB(name, ix, subaddr, filename)
2520 char *name;
2521 I32 ix;
2522 I32 (*subaddr)();
2523 char *filename;
2524 {
2525     register CV *cv;
2526     GV *gv = gv_fetchpv(name,2, SVt_PVCV);
2527     char *s;
2528
2529     sub_generation++;
2530     if ((cv = GvCV(gv)) && !GvCVGEN(gv)) {
2531         if (dowarn)
2532             warn("Subroutine %s redefined",name);
2533         if (!CvUSERSUB(cv) && CvROOT(cv)) {
2534             op_free(CvROOT(cv));
2535             CvROOT(cv) = Nullop;
2536         }
2537         Safefree(cv);
2538     }
2539     Newz(101,cv,1,CV);
2540     sv_upgrade(cv, SVt_PVCV);
2541     SvREFCNT(cv) = 1;
2542     GvCV(gv) = cv;
2543     CvGV(cv) = SvREFCNT_inc(gv);
2544     GvCVGEN(gv) = 0;
2545     CvFILEGV(cv) = gv_fetchfile(filename);
2546     CvUSERSUB(cv) = subaddr;
2547     CvUSERINDEX(cv) = ix;
2548     CvDELETED(cv) = FALSE;
2549     if (s = strrchr(name,':'))
2550         s++;
2551     else
2552         s = name;
2553     if (strEQ(s, "BEGIN")) {
2554         if (!beginav)
2555             beginav = newAV();
2556         av_push(beginav, SvREFCNT_inc(gv));
2557     }
2558     else if (strEQ(s, "END")) {
2559         if (!endav)
2560             endav = newAV();
2561         av_unshift(endav, 1);
2562         av_store(endav, 0, SvREFCNT_inc(gv));
2563     }
2564 }
2565
2566 void
2567 newFORM(floor,op,block)
2568 I32 floor;
2569 OP *op;
2570 OP *block;
2571 {
2572     register CV *cv;
2573     char *name;
2574     GV *gv;
2575     AV* av;
2576
2577     if (op)
2578         name = SvPVx(cSVOP->op_sv, na);
2579     else
2580         name = "STDOUT";
2581     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
2582     if (cv = GvFORM(gv)) {
2583         if (dowarn) {
2584             line_t oldline = curcop->cop_line;
2585
2586             curcop->cop_line = copline;
2587             warn("Format %s redefined",name);
2588             curcop->cop_line = oldline;
2589         }
2590         SvREFCNT_dec(cv);
2591     }
2592     Newz(101,cv,1,CV);
2593     sv_upgrade(cv, SVt_PVFM);
2594     SvREFCNT(cv) = 1;
2595     GvFORM(gv) = cv;
2596     CvGV(cv) = SvREFCNT_inc(gv);
2597     CvFILEGV(cv) = curcop->cop_filegv;
2598
2599     CvPADLIST(cv) = av = newAV();
2600     AvREAL_off(av);
2601     av_store(av, 1, (SV*)comppad);
2602     AvFILL(av) = 1;
2603
2604     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
2605     CvSTART(cv) = LINKLIST(CvROOT(cv));
2606     CvROOT(cv)->op_next = 0;
2607     peep(CvSTART(cv));
2608     CvDELETED(cv) = FALSE;
2609     FmLINES(cv) = 0;
2610     op_free(op);
2611     copline = NOLINE;
2612     LEAVE_SCOPE(floor);
2613 }
2614
2615 OP *
2616 newMETHOD(ref,name)
2617 OP *ref;
2618 OP *name;
2619 {
2620     LOGOP* mop;
2621     Newz(1101, mop, 1, LOGOP);
2622     mop->op_type = OP_METHOD;
2623     mop->op_ppaddr = ppaddr[OP_METHOD];
2624     mop->op_first = scalar(ref);
2625     mop->op_flags |= OPf_KIDS;
2626     mop->op_private = 1;
2627     mop->op_other = LINKLIST(name);
2628     mop->op_targ = pad_alloc(OP_METHOD, SVs_PADTMP);
2629     mop->op_next = LINKLIST(ref);
2630     ref->op_next = (OP*)mop;
2631     return scalar((OP*)mop);
2632 }
2633
2634 OP *
2635 newANONLIST(op)
2636 OP* op;
2637 {
2638     return newUNOP(OP_REFGEN, 0,
2639         ref(list(convert(OP_ANONLIST, 0, op)), OP_REFGEN));
2640 }
2641
2642 OP *
2643 newANONHASH(op)
2644 OP* op;
2645 {
2646     return newUNOP(OP_REFGEN, 0,
2647         ref(list(convert(OP_ANONHASH, 0, op)), OP_REFGEN));
2648 }
2649
2650 OP *
2651 oopsAV(o)
2652 OP *o;
2653 {
2654     switch (o->op_type) {
2655     case OP_PADSV:
2656         o->op_type = OP_PADAV;
2657         o->op_ppaddr = ppaddr[OP_PADAV];
2658         return ref(newUNOP(OP_RV2AV, 0, scalar(o)), OP_RV2AV);
2659
2660     case OP_RV2SV:
2661         o->op_type = OP_RV2AV;
2662         o->op_ppaddr = ppaddr[OP_RV2AV];
2663         ref(o, OP_RV2AV);
2664         break;
2665
2666     default:
2667         warn("oops: oopsAV");
2668         break;
2669     }
2670     return o;
2671 }
2672
2673 OP *
2674 oopsHV(o)
2675 OP *o;
2676 {
2677     switch (o->op_type) {
2678     case OP_PADSV:
2679     case OP_PADAV:
2680         o->op_type = OP_PADHV;
2681         o->op_ppaddr = ppaddr[OP_PADHV];
2682         return ref(newUNOP(OP_RV2HV, 0, scalar(o)), OP_RV2HV);
2683
2684     case OP_RV2SV:
2685     case OP_RV2AV:
2686         o->op_type = OP_RV2HV;
2687         o->op_ppaddr = ppaddr[OP_RV2HV];
2688         ref(o, OP_RV2HV);
2689         break;
2690
2691     default:
2692         warn("oops: oopsHV");
2693         break;
2694     }
2695     return o;
2696 }
2697
2698 OP *
2699 newAVREF(o)
2700 OP *o;
2701 {
2702     if (o->op_type == OP_PADANY) {
2703         o->op_type = OP_PADAV;
2704         o->op_ppaddr = ppaddr[OP_PADAV];
2705         return o;
2706     }
2707     return newUNOP(OP_RV2AV, 0, scalar(o));
2708 }
2709
2710 OP *
2711 newGVREF(o)
2712 OP *o;
2713 {
2714     return newUNOP(OP_RV2GV, 0, scalar(o));
2715 }
2716
2717 OP *
2718 newHVREF(o)
2719 OP *o;
2720 {
2721     if (o->op_type == OP_PADANY) {
2722         o->op_type = OP_PADHV;
2723         o->op_ppaddr = ppaddr[OP_PADHV];
2724         return o;
2725     }
2726     return newUNOP(OP_RV2HV, 0, scalar(o));
2727 }
2728
2729 OP *
2730 oopsCV(o)
2731 OP *o;
2732 {
2733     croak("NOT IMPL LINE %d",__LINE__);
2734     /* STUB */
2735     return o;
2736 }
2737
2738 OP *
2739 newCVREF(o)
2740 OP *o;
2741 {
2742     return newUNOP(OP_RV2CV, 0, scalar(o));
2743 }
2744
2745 OP *
2746 newSVREF(o)
2747 OP *o;
2748 {
2749     if (o->op_type == OP_PADANY) {
2750         o->op_type = OP_PADSV;
2751         o->op_ppaddr = ppaddr[OP_PADSV];
2752         return o;
2753     }
2754     return newUNOP(OP_RV2SV, 0, scalar(o));
2755 }
2756
2757 /* Check routines. */
2758
2759 OP *
2760 ck_concat(op)
2761 OP *op;
2762 {
2763     if (cUNOP->op_first->op_type == OP_CONCAT)
2764         op->op_flags |= OPf_STACKED;
2765     return op;
2766 }
2767
2768 OP *
2769 ck_chop(op)
2770 OP *op;
2771 {
2772     if (op->op_flags & OPf_KIDS) {
2773         OP* newop;
2774         op = modkids(ck_fun(op), op->op_type);
2775         if (op->op_private != 1)
2776             return op;
2777         newop = cUNOP->op_first->op_sibling;
2778         if (!newop || newop->op_type != OP_RV2SV)
2779             return op;
2780         op_free(cUNOP->op_first);
2781         cUNOP->op_first = newop;
2782     }
2783     op->op_type = OP_SCHOP;
2784     op->op_ppaddr = ppaddr[OP_SCHOP];
2785     return op;
2786 }
2787
2788 OP *
2789 ck_eof(op)
2790 OP *op;
2791 {
2792     I32 type = op->op_type;
2793
2794     if (op->op_flags & OPf_KIDS) {
2795         if (cLISTOP->op_first->op_type == OP_STUB) {
2796             op_free(op);
2797             op = newUNOP(type, OPf_SPECIAL,
2798                 newGVOP(OP_GV, 0, gv_fetchpv("main'ARGV", TRUE, SVt_PVAV)));
2799         }
2800         return ck_fun(op);
2801     }
2802     return op;
2803 }
2804
2805 OP *
2806 ck_eval(op)
2807 OP *op;
2808 {
2809     hints |= HINT_BLOCK_SCOPE;
2810     if (op->op_flags & OPf_KIDS) {
2811         SVOP *kid = (SVOP*)cUNOP->op_first;
2812
2813         if (!kid) {
2814             op->op_flags &= ~OPf_KIDS;
2815             null(op);
2816         }
2817         else if (kid->op_type == OP_LINESEQ) {
2818             LOGOP *enter;
2819
2820             kid->op_next = op->op_next;
2821             cUNOP->op_first = 0;
2822             op_free(op);
2823
2824             Newz(1101, enter, 1, LOGOP);
2825             enter->op_type = OP_ENTERTRY;
2826             enter->op_ppaddr = ppaddr[OP_ENTERTRY];
2827             enter->op_private = 0;
2828
2829             /* establish postfix order */
2830             enter->op_next = (OP*)enter;
2831
2832             op = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
2833             op->op_type = OP_LEAVETRY;
2834             op->op_ppaddr = ppaddr[OP_LEAVETRY];
2835             enter->op_other = op;
2836             return op;
2837         }
2838     }
2839     else {
2840         op_free(op);
2841         op = newUNOP(OP_ENTEREVAL, 0, newSVREF(newGVOP(OP_GV, 0, defgv)));
2842     }
2843     return op;
2844 }
2845
2846 OP *
2847 ck_exec(op)
2848 OP *op;
2849 {
2850     OP *kid;
2851     if (op->op_flags & OPf_STACKED) {
2852         op = ck_fun(op);
2853         kid = cUNOP->op_first->op_sibling;
2854         if (kid->op_type == OP_RV2GV)
2855             null(kid);
2856     }
2857     else
2858         op = listkids(op);
2859     return op;
2860 }
2861
2862 OP *
2863 ck_gvconst(o)
2864 register OP *o;
2865 {
2866     o = fold_constants(o);
2867     if (o->op_type == OP_CONST)
2868         o->op_type = OP_GV;
2869     return o;
2870 }
2871
2872 OP *
2873 ck_rvconst(op)
2874 register OP *op;
2875 {
2876     SVOP *kid = (SVOP*)cUNOP->op_first;
2877     int iscv = (op->op_type==OP_RV2CV);
2878
2879     if (kid->op_type == OP_CONST) {
2880         kid->op_type = OP_GV;
2881         kid->op_sv = SvREFCNT_inc(gv_fetchpv(SvPVx(kid->op_sv, na),
2882                 1+iscv, iscv ? SVt_PVCV : SVt_PVGV));
2883     }
2884     return op;
2885 }
2886
2887 OP *
2888 ck_formline(op)
2889 OP *op;
2890 {
2891     return ck_fun(op);
2892 }
2893
2894 OP *
2895 ck_ftst(op)
2896 OP *op;
2897 {
2898     I32 type = op->op_type;
2899
2900     if (op->op_flags & OPf_SPECIAL)
2901         return op;
2902
2903     if (op->op_flags & OPf_KIDS) {
2904         SVOP *kid = (SVOP*)cUNOP->op_first;
2905
2906         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
2907             OP *newop = newGVOP(type, OPf_SPECIAL,
2908                 gv_fetchpv(SvPVx(kid->op_sv, na), TRUE, SVt_PVIO));
2909             op_free(op);
2910             return newop;
2911         }
2912     }
2913     else {
2914         op_free(op);
2915         if (type == OP_FTTTY)
2916             return newGVOP(type, OPf_SPECIAL, gv_fetchpv("main'STDIN", TRUE,
2917                                 SVt_PVIO));
2918         else
2919             return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv)));
2920     }
2921     return op;
2922 }
2923
2924 OP *
2925 ck_fun(op)
2926 OP *op;
2927 {
2928     register OP *kid;
2929     OP **tokid;
2930     OP *sibl;
2931     I32 numargs = 0;
2932     register I32 oa = opargs[op->op_type] >> 8;
2933
2934     if (op->op_flags & OPf_STACKED) {
2935         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
2936             oa &= ~OA_OPTIONAL;
2937         else
2938             return no_fh_allowed(op);
2939     }
2940
2941     if (op->op_flags & OPf_KIDS) {
2942         tokid = &cLISTOP->op_first;
2943         kid = cLISTOP->op_first;
2944         if (kid->op_type == OP_PUSHMARK ||
2945             kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)
2946         {
2947             tokid = &kid->op_sibling;
2948             kid = kid->op_sibling;
2949         }
2950
2951         while (oa && kid) {
2952             numargs++;
2953             sibl = kid->op_sibling;
2954             switch (oa & 7) {
2955             case OA_SCALAR:
2956                 scalar(kid);
2957                 break;
2958             case OA_LIST:
2959                 if (oa < 16) {
2960                     kid = 0;
2961                     continue;
2962                 }
2963                 else
2964                     list(kid);
2965                 break;
2966             case OA_AVREF:
2967                 if (kid->op_type == OP_CONST &&
2968                   (kid->op_private & OPpCONST_BARE)) {
2969                     char *name = SvPVx(((SVOP*)kid)->op_sv, na);
2970                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
2971                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
2972                     if (dowarn)
2973                         warn("Array @%s missing the @ in argument %d of %s()",
2974                             name, numargs, op_name[op->op_type]);
2975                     op_free(kid);
2976                     kid = newop;
2977                     kid->op_sibling = sibl;
2978                     *tokid = kid;
2979                 }
2980                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
2981                     bad_type(numargs, "array", op, kid);
2982                 mod(kid, op->op_type);
2983                 break;
2984             case OA_HVREF:
2985                 if (kid->op_type == OP_CONST &&
2986                   (kid->op_private & OPpCONST_BARE)) {
2987                     char *name = SvPVx(((SVOP*)kid)->op_sv, na);
2988                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
2989                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
2990                     if (dowarn)
2991                         warn("Hash %%%s missing the %% in argument %d of %s()",
2992                             name, numargs, op_name[op->op_type]);
2993                     op_free(kid);
2994                     kid = newop;
2995                     kid->op_sibling = sibl;
2996                     *tokid = kid;
2997                 }
2998                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
2999                     bad_type(numargs, "hash", op, kid);
3000                 mod(kid, op->op_type);
3001                 break;
3002             case OA_CVREF:
3003                 {
3004                     OP *newop = newUNOP(OP_NULL, 0, scalar(kid));
3005                     kid->op_sibling = 0;
3006                     linklist(kid);
3007                     newop->op_next = newop;
3008                     kid = newop;
3009                     kid->op_sibling = sibl;
3010                     *tokid = kid;
3011                 }
3012                 break;
3013             case OA_FILEREF:
3014                 if (kid->op_type != OP_GV) {
3015                     if (kid->op_type == OP_CONST &&
3016                       (kid->op_private & OPpCONST_BARE)) {
3017                         OP *newop = newGVOP(OP_GV, 0,
3018                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, na), TRUE,
3019                                         SVt_PVIO) );
3020                         op_free(kid);
3021                         kid = newop;
3022                     }
3023                     else {
3024                         kid->op_sibling = 0;
3025                         kid = newUNOP(OP_RV2GV, 0, scalar(kid));
3026                     }
3027                     kid->op_sibling = sibl;
3028                     *tokid = kid;
3029                 }
3030                 scalar(kid);
3031                 break;
3032             case OA_SCALARREF:
3033                 mod(scalar(kid), op->op_type);
3034                 break;
3035             }
3036             oa >>= 4;
3037             tokid = &kid->op_sibling;
3038             kid = kid->op_sibling;
3039         }
3040         op->op_private = numargs;
3041         if (kid)
3042             return too_many_arguments(op);
3043         listkids(op);
3044     }
3045     if (oa) {
3046         while (oa & OA_OPTIONAL)
3047             oa >>= 4;
3048         if (oa && oa != OA_LIST)
3049             return too_few_arguments(op);
3050     }
3051     return op;
3052 }
3053
3054 OP *
3055 ck_glob(op)
3056 OP *op;
3057 {
3058     GV *gv = newGVgen();
3059     GvIOn(gv);
3060     append_elem(OP_GLOB, op, newGVOP(OP_GV, 0, gv));
3061     scalarkids(op);
3062     return op;
3063 }
3064
3065 OP *
3066 ck_grep(op)
3067 OP *op;
3068 {
3069     LOGOP *gwop;
3070     OP *kid;
3071
3072     if (op->op_flags & OPf_STACKED) {
3073         op = ck_sort(op);
3074         op->op_flags &= ~OPf_STACKED;
3075     }
3076     op = ck_fun(op);
3077     if (error_count)
3078         return op;
3079     kid = cLISTOP->op_first->op_sibling;
3080     if (kid->op_type != OP_NULL)
3081         croak("panic: ck_grep");
3082     kid = kUNOP->op_first;
3083
3084     Newz(1101, gwop, 1, LOGOP);
3085     gwop->op_type = OP_GREPWHILE;
3086     gwop->op_ppaddr = ppaddr[OP_GREPWHILE];
3087     gwop->op_first = list(op);
3088     gwop->op_flags |= OPf_KIDS;
3089     gwop->op_private = 1;
3090     gwop->op_other = LINKLIST(kid);
3091     gwop->op_targ = pad_alloc(OP_GREPWHILE, SVs_PADTMP);
3092     kid->op_next = (OP*)gwop;
3093
3094     return (OP*)gwop;
3095 }
3096
3097 OP *
3098 ck_index(op)
3099 OP *op;
3100 {
3101     if (op->op_flags & OPf_KIDS) {
3102         OP *kid = cLISTOP->op_first->op_sibling;        /* get past pushmark */
3103         if (kid && kid->op_type == OP_CONST)
3104             fbm_compile(((SVOP*)kid)->op_sv, 0);
3105     }
3106     return ck_fun(op);
3107 }
3108
3109 OP *
3110 ck_lengthconst(op)
3111 OP *op;
3112 {
3113     /* XXX length optimization goes here */
3114     return op;
3115 }
3116
3117 OP *
3118 ck_lfun(op)
3119 OP *op;
3120 {
3121     return modkids(ck_fun(op), op->op_type);
3122 }
3123
3124 OP *
3125 ck_rfun(op)
3126 OP *op;
3127 {
3128     return refkids(ck_fun(op), op->op_type);
3129 }
3130
3131 OP *
3132 ck_listiob(op)
3133 OP *op;
3134 {
3135     register OP *kid;
3136
3137     kid = cLISTOP->op_first;
3138     if (!kid) {
3139         op = force_list(op);
3140         kid = cLISTOP->op_first;
3141     }
3142     if (kid->op_type == OP_PUSHMARK)
3143         kid = kid->op_sibling;
3144     if (kid && op->op_flags & OPf_STACKED)
3145         kid = kid->op_sibling;
3146     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
3147         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
3148             op->op_flags |= OPf_STACKED;        /* make it a filehandle */
3149             kid = newUNOP(OP_RV2GV, 0, scalar(kid));
3150             cLISTOP->op_first->op_sibling = kid;
3151             cLISTOP->op_last = kid;
3152             kid = kid->op_sibling;
3153         }
3154     }
3155
3156     if (!kid)
3157         append_elem(op->op_type, op, newSVREF(newGVOP(OP_GV, 0, defgv)) );
3158
3159     return listkids(op);
3160 }
3161
3162 OP *
3163 ck_match(op)
3164 OP *op;
3165 {
3166     cPMOP->op_pmflags |= PMf_RUNTIME;
3167     return op;
3168 }
3169
3170 OP *
3171 ck_null(op)
3172 OP *op;
3173 {
3174     return op;
3175 }
3176
3177 OP *
3178 ck_repeat(op)
3179 OP *op;
3180 {
3181     if (cBINOP->op_first->op_flags & OPf_PARENS) {
3182         op->op_private = OPpREPEAT_DOLIST;
3183         cBINOP->op_first = force_list(cBINOP->op_first);
3184     }
3185     else
3186         scalar(op);
3187     return op;
3188 }
3189
3190 OP *
3191 ck_require(op)
3192 OP *op;
3193 {
3194     if (op->op_flags & OPf_KIDS) {      /* Shall we fake a BEGIN {}? */
3195         SVOP *kid = (SVOP*)cUNOP->op_first;
3196
3197         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3198             char *name = SvPVX(subname);
3199             char *s;
3200             sv_catpvn(kid->op_sv, ".pm", 3);
3201             if (s = strrchr(name,':'))
3202                 s++;
3203             else
3204                 s = name;
3205             if (strNE(s, "BEGIN")) {
3206                 op = newSTATEOP(0, Nullch, op);
3207                 newSUB(start_subparse(),
3208                        newSVOP(OP_CONST, 0, newSVpv("BEGIN", 5)),
3209                        op);
3210                 return newOP(OP_STUB,0);
3211             }
3212         }
3213     }
3214     return ck_fun(op);
3215 }
3216
3217 OP *
3218 ck_retarget(op)
3219 OP *op;
3220 {
3221     croak("NOT IMPL LINE %d",__LINE__);
3222     /* STUB */
3223     return op;
3224 }
3225
3226 OP *
3227 ck_select(op)
3228 OP *op;
3229 {
3230     if (op->op_flags & OPf_KIDS) {
3231         OP *kid = cLISTOP->op_first->op_sibling;        /* get past pushmark */
3232         if (kid && kid->op_sibling) {
3233             op->op_type = OP_SSELECT;
3234             op->op_ppaddr = ppaddr[OP_SSELECT];
3235             op = ck_fun(op);
3236             return fold_constants(op);
3237         }
3238     }
3239     return ck_fun(op);
3240 }
3241
3242 OP *
3243 ck_shift(op)
3244 OP *op;
3245 {
3246     I32 type = op->op_type;
3247
3248     if (!(op->op_flags & OPf_KIDS)) {
3249         op_free(op);
3250         return newUNOP(type, 0,
3251             scalar(newUNOP(OP_RV2AV, 0,
3252                 scalar(newGVOP(OP_GV, 0,
3253                     gv_fetchpv((subline ? "_" : "ARGV"), TRUE, SVt_PVAV) )))));
3254     }
3255     return scalar(modkids(ck_fun(op), type));
3256 }
3257
3258 OP *
3259 ck_sort(op)
3260 OP *op;
3261 {
3262     if (op->op_flags & OPf_STACKED) {
3263         OP *kid = cLISTOP->op_first->op_sibling;        /* get past pushmark */
3264         OP *k;
3265         kid = kUNOP->op_first;                          /* get past rv2gv */
3266
3267         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
3268             linklist(kid);
3269             if (kid->op_type == OP_SCOPE) {
3270                 k = kid->op_next;
3271                 kid->op_next = 0;
3272                 peep(k);
3273             }
3274             else if (kid->op_type == OP_LEAVE) {
3275                 null(kid);                      /* wipe out leave */
3276                 kid->op_next = kid;
3277
3278                 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
3279                     if (k->op_next == kid)
3280                         k->op_next = 0;
3281                 }
3282                 peep(kLISTOP->op_first);
3283             }
3284             kid = cLISTOP->op_first->op_sibling;        /* get past pushmark */
3285             null(kid);                                  /* wipe out rv2gv */
3286             kid->op_next = kid;
3287             op->op_flags |= OPf_SPECIAL;
3288         }
3289     }
3290     return op;
3291 }
3292
3293 OP *
3294 ck_split(op)
3295 OP *op;
3296 {
3297     register OP *kid;
3298     PMOP* pm;
3299
3300     if (op->op_flags & OPf_STACKED)
3301         return no_fh_allowed(op);
3302
3303     kid = cLISTOP->op_first;
3304     if (kid->op_type != OP_NULL)
3305         croak("panic: ck_split");
3306     kid = kid->op_sibling;
3307     op_free(cLISTOP->op_first);
3308     cLISTOP->op_first = kid;
3309     if (!kid) {
3310         cLISTOP->op_first = kid = newSVOP(OP_CONST, 0, newSVpv(" ", 1));
3311         cLISTOP->op_last = kid; /* There was only one element previously */
3312     }
3313
3314     if (kid->op_type != OP_MATCH) {
3315         OP *sibl = kid->op_sibling;
3316         kid->op_sibling = 0;
3317         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
3318         if (cLISTOP->op_first == cLISTOP->op_last)
3319             cLISTOP->op_last = kid;
3320         cLISTOP->op_first = kid;
3321         kid->op_sibling = sibl;
3322     }
3323     pm = (PMOP*)kid;
3324     if (pm->op_pmshort && !(pm->op_pmflags & PMf_ALL)) {
3325         SvREFCNT_dec(pm->op_pmshort);   /* can't use substring to optimize */
3326         pm->op_pmshort = 0;
3327     }
3328
3329     kid->op_type = OP_PUSHRE;
3330     kid->op_ppaddr = ppaddr[OP_PUSHRE];
3331     scalar(kid);
3332
3333     if (!kid->op_sibling)
3334         append_elem(OP_SPLIT, op, newSVREF(newGVOP(OP_GV, 0, defgv)) );
3335
3336     kid = kid->op_sibling;
3337     scalar(kid);
3338
3339     if (!kid->op_sibling)
3340         append_elem(OP_SPLIT, op, newSVOP(OP_CONST, 0, newSViv(0)));
3341
3342     kid = kid->op_sibling;
3343     scalar(kid);
3344
3345     if (kid->op_sibling)
3346         return too_many_arguments(op);
3347
3348     return op;
3349 }
3350
3351 OP *
3352 ck_subr(op)
3353 OP *op;
3354 {
3355     OP *o = ((cUNOP->op_first->op_sibling)
3356              ? cUNOP : ((UNOP*)cUNOP->op_first))->op_first->op_sibling;
3357
3358     if (o->op_type == OP_RV2CV)
3359         null(o);                /* disable rv2cv */
3360     op->op_private = (hints & HINT_STRICT_REFS);
3361     if (perldb && curstash != debstash)
3362         op->op_private |= OPpDEREF_DB;
3363     return op;
3364 }
3365
3366 OP *
3367 ck_svconst(op)
3368 OP *op;
3369 {
3370     SvREADONLY_on(cSVOP->op_sv);
3371     return op;
3372 }
3373
3374 OP *
3375 ck_trunc(op)
3376 OP *op;
3377 {
3378     if (op->op_flags & OPf_KIDS) {
3379         SVOP *kid = (SVOP*)cUNOP->op_first;
3380
3381         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE))
3382             op->op_flags |= OPf_SPECIAL;
3383     }
3384     return ck_fun(op);
3385 }
3386
3387 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
3388
3389 void
3390 peep(op)
3391 register OP* op;
3392 {
3393     register OP* oldop = 0;
3394     if (!op || op->op_seq)
3395         return;
3396     for (; op; op = op->op_next) {
3397         if (op->op_seq)
3398             return;
3399         switch (op->op_type) {
3400         case OP_STUB:
3401             if ((op->op_flags & (OPf_KNOW|OPf_LIST)) != (OPf_KNOW|OPf_LIST)) {
3402                 op->op_seq = ++op_seqmax;
3403                 break;  /* Scalar stub must produce undef.  List stub is noop */
3404             }
3405             /* FALL THROUGH */
3406         case OP_NULL:
3407         case OP_SCALAR:
3408         case OP_LINESEQ:
3409         case OP_SCOPE:
3410             if (oldop) {
3411                 oldop->op_next = op->op_next;
3412                 continue;
3413             }
3414             op->op_seq = ++op_seqmax;
3415             break;
3416
3417         case OP_GV:
3418             if (op->op_next->op_type == OP_RV2SV) {
3419                 if (!(op->op_next->op_private & (OPpDEREF_HV|OPpDEREF_AV))) {
3420                     null(op->op_next);
3421                     op->op_flags |= op->op_next->op_flags & OPf_INTRO;
3422                     op->op_next = op->op_next->op_next;
3423                     op->op_type = OP_GVSV;
3424                     op->op_ppaddr = ppaddr[OP_GVSV];
3425                 }
3426             }
3427             else if (op->op_next->op_type == OP_RV2AV) {
3428                 OP* pop = op->op_next->op_next;
3429                 I32 i;
3430                 if (pop->op_type == OP_CONST &&
3431                     pop->op_next->op_type == OP_AELEM &&
3432                     !(pop->op_next->op_private & (OPpDEREF_HV|OPpDEREF_AV)) &&
3433                     !(pop->op_next->op_flags & OPf_INTRO) &&
3434                     (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 &&
3435                     i >= 0)
3436                 {
3437                     null(op->op_next);
3438                     null(pop->op_next);
3439                     null(pop);
3440                     op->op_flags &= ~OPf_LVAL;
3441                     op->op_flags |= pop->op_next->op_flags & OPf_LVAL;
3442                     op->op_next = pop->op_next->op_next;
3443                     op->op_type = OP_AELEMFAST;
3444                     op->op_ppaddr = ppaddr[OP_AELEMFAST];
3445                     op->op_private = i;
3446                     GvAVn((GV*)cSVOP->op_sv);
3447                 }
3448             }
3449             op->op_seq = ++op_seqmax;
3450             break;
3451
3452         case OP_GREPWHILE:
3453         case OP_AND:
3454         case OP_OR:
3455             op->op_seq = ++op_seqmax;
3456             peep(cLOGOP->op_other);
3457             break;
3458
3459         case OP_COND_EXPR:
3460             op->op_seq = ++op_seqmax;
3461             peep(cCONDOP->op_true);
3462             peep(cCONDOP->op_false);
3463             break;
3464
3465         case OP_ENTERLOOP:
3466             op->op_seq = ++op_seqmax;
3467             peep(cLOOP->op_redoop);
3468             peep(cLOOP->op_nextop);
3469             peep(cLOOP->op_lastop);
3470             break;
3471
3472         case OP_MATCH:
3473         case OP_SUBST:
3474             op->op_seq = ++op_seqmax;
3475             peep(cPMOP->op_pmreplroot);
3476             break;
3477
3478         default:
3479             op->op_seq = ++op_seqmax;
3480             break;
3481         }
3482         oldop = op;
3483     }
3484 }