consarg.c

   1 /* $Header: consarg.c,v 3.0.1.8 91/01/11 17:37:31 lwall Locked $
   2  *
   3  *    Copyright (c) 1989, Larry Wall
   4  *
   5  *    You may distribute under the terms of the GNU General Public License
   6  *    as specified in the README file that comes with the perl 3.0 kit.
   7  *
   8  * $Log:        consarg.c,v $
   9  * Revision 3.0.1.8  91/01/11  17:37:31  lwall
  10  * patch42: assignment to a slice didn't supply an array context to RHS
  11  * patch42: suppressed variable suicide on local($a,$b) = @_
  12  *
  13  * Revision 3.0.1.7  90/10/15  15:55:28  lwall
  14  * patch29: defined @foo was behaving inconsistently
  15  * patch29: -5 % 5 was wrong
  16  * patch29: package behavior is now more consistent
  17  *
  18  * Revision 3.0.1.6  90/08/09  02:38:51  lwall
  19  * patch19: fixed problem with % of negative number
  20  *
  21  * Revision 3.0.1.5  90/03/27  15:36:45  lwall
  22  * patch16: support for machines that can't cast negative floats to unsigned ints
  23  *
  24  * Revision 3.0.1.4  90/03/12  16:24:40  lwall
  25  * patch13: return (@array) did counter-intuitive things
  26  *
  27  * Revision 3.0.1.3  90/02/28  16:47:54  lwall
  28  * patch9: the x operator is now up to 10 times faster
  29  * patch9: @_ clobbered by ($foo,$bar) = split
  30  *
  31  * Revision 3.0.1.2  89/11/17  15:11:34  lwall
  32  * patch5: defined $foo{'bar'} should not create element
  33  *
  34  * Revision 3.0.1.1  89/11/11  04:14:30  lwall
  35  * patch2: '-' x 26 made warnings about undefined value
  36  * patch2: eval with no args caused strangeness
  37  * patch2: local(@foo) didn't work, but local(@foo,$bar) did
  38  *
  39  * Revision 3.0  89/10/18  15:10:30  lwall
  40  * 3.0 baseline
  41  *
  42  */
  43
  44 #include "EXTERN.h"
  45 #include "perl.h"
  46 static int nothing_in_common();
  47 static int arg_common();
  48 static int spat_common();
  49
  50 ARG *
  51 make_split(stab,arg,limarg)
  52 register STAB *stab;
  53 register ARG *arg;
  54 ARG *limarg;
  55 {
  56     register SPAT *spat;
  57
  58     if (arg->arg_type != O_MATCH) {
  59         Newz(201,spat,1,SPAT);
  60         spat->spat_next = curstash->tbl_spatroot; /* link into spat list */
  61         curstash->tbl_spatroot = spat;
  62
  63         spat->spat_runtime = arg;
  64         arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat);
  65     }
  66     Renew(arg,4,ARG);
  67     arg->arg_len = 3;
  68     if (limarg) {
  69         if (limarg->arg_type == O_ITEM) {
  70             Copy(limarg+1,arg+3,1,ARG);
  71             limarg[1].arg_type = A_NULL;
  72             arg_free(limarg);
  73         }
  74         else {
  75             arg[3].arg_flags = 0;
  76             arg[3].arg_type = A_EXPR;
  77             arg[3].arg_ptr.arg_arg = limarg;
  78         }
  79     }
  80     else
  81         arg[3].arg_type = A_NULL;
  82     arg->arg_type = O_SPLIT;
  83     spat = arg[2].arg_ptr.arg_spat;
  84     spat->spat_repl = stab2arg(A_STAB,aadd(stab));
  85     if (spat->spat_short) {     /* exact match can bypass regexec() */
  86         if (!((spat->spat_flags & SPAT_SCANFIRST) &&
  87             (spat->spat_flags & SPAT_ALL) )) {
  88             str_free(spat->spat_short);
  89             spat->spat_short = Nullstr;
  90         }
  91     }
  92     return arg;
  93 }
  94
  95 ARG *
  96 mod_match(type,left,pat)
  97 register ARG *left;
  98 register ARG *pat;
  99 {
 100
 101     register SPAT *spat;
 102     register ARG *newarg;
 103
 104     if (!pat)
 105         return Nullarg;
 106
 107     if ((pat->arg_type == O_MATCH ||
 108          pat->arg_type == O_SUBST ||
 109          pat->arg_type == O_TRANS ||
 110          pat->arg_type == O_SPLIT
 111         ) &&
 112         pat[1].arg_ptr.arg_stab == defstab ) {
 113         switch (pat->arg_type) {
 114         case O_MATCH:
 115             newarg = make_op(type == O_MATCH ? O_MATCH : O_NMATCH,
 116                 pat->arg_len,
 117                 left,Nullarg,Nullarg);
 118             break;
 119         case O_SUBST:
 120             newarg = l(make_op(type == O_MATCH ? O_SUBST : O_NSUBST,
 121                 pat->arg_len,
 122                 left,Nullarg,Nullarg));
 123             break;
 124         case O_TRANS:
 125             newarg = l(make_op(type == O_MATCH ? O_TRANS : O_NTRANS,
 126                 pat->arg_len,
 127                 left,Nullarg,Nullarg));
 128             break;
 129         case O_SPLIT:
 130             newarg = make_op(type == O_MATCH ? O_SPLIT : O_SPLIT,
 131                 pat->arg_len,
 132                 left,Nullarg,Nullarg);
 133             break;
 134         }
 135         if (pat->arg_len >= 2) {
 136             newarg[2].arg_type = pat[2].arg_type;
 137             newarg[2].arg_ptr = pat[2].arg_ptr;
 138             newarg[2].arg_flags = pat[2].arg_flags;
 139             if (pat->arg_len >= 3) {
 140                 newarg[3].arg_type = pat[3].arg_type;
 141                 newarg[3].arg_ptr = pat[3].arg_ptr;
 142                 newarg[3].arg_flags = pat[3].arg_flags;
 143             }
 144         }
 145         Safefree(pat);
 146     }
 147     else {
 148         Newz(202,spat,1,SPAT);
 149         spat->spat_next = curstash->tbl_spatroot; /* link into spat list */
 150         curstash->tbl_spatroot = spat;
 151
 152         spat->spat_runtime = pat;
 153         newarg = make_op(type,2,left,Nullarg,Nullarg);
 154         newarg[2].arg_type = A_SPAT | A_DONT;
 155         newarg[2].arg_ptr.arg_spat = spat;
 156     }
 157
 158     return newarg;
 159 }
 160
 161 ARG *
 162 make_op(type,newlen,arg1,arg2,arg3)
 163 int type;
 164 int newlen;
 165 ARG *arg1;
 166 ARG *arg2;
 167 ARG *arg3;
 168 {
 169     register ARG *arg;
 170     register ARG *chld;
 171     register unsigned doarg;
 172     register int i;
 173     extern ARG *arg4;   /* should be normal arguments, really */
 174     extern ARG *arg5;
 175
 176     arg = op_new(newlen);
 177     arg->arg_type = type;
 178     if (chld = arg1) {
 179         if (chld->arg_type == O_ITEM &&
 180             (hoistable[ i = (chld[1].arg_type&A_MASK)] || i == A_LVAL ||
 181              (i == A_LEXPR &&
 182               (chld[1].arg_ptr.arg_arg->arg_type == O_LIST ||
 183                chld[1].arg_ptr.arg_arg->arg_type == O_ARRAY ||
 184                chld[1].arg_ptr.arg_arg->arg_type == O_HASH ))))
 185         {
 186             arg[1].arg_type = chld[1].arg_type;
 187             arg[1].arg_ptr = chld[1].arg_ptr;
 188             arg[1].arg_flags |= chld[1].arg_flags;
 189             arg[1].arg_len = chld[1].arg_len;
 190             free_arg(chld);
 191         }
 192         else {
 193             arg[1].arg_type = A_EXPR;
 194             arg[1].arg_ptr.arg_arg = chld;
 195         }
 196     }
 197     if (chld = arg2) {
 198         if (chld->arg_type == O_ITEM &&
 199             (hoistable[chld[1].arg_type&A_MASK] ||
 200              (type == O_ASSIGN &&
 201               ((chld[1].arg_type == A_READ && !(arg[1].arg_type & A_DONT))
 202                 ||
 203                (chld[1].arg_type == A_INDREAD && !(arg[1].arg_type & A_DONT))
 204                 ||
 205                (chld[1].arg_type == A_GLOB && !(arg[1].arg_type & A_DONT))
 206               ) ) ) ) {
 207             arg[2].arg_type = chld[1].arg_type;
 208             arg[2].arg_ptr = chld[1].arg_ptr;
 209             arg[2].arg_len = chld[1].arg_len;
 210             free_arg(chld);
 211         }
 212         else {
 213             arg[2].arg_type = A_EXPR;
 214             arg[2].arg_ptr.arg_arg = chld;
 215         }
 216     }
 217     if (chld = arg3) {
 218         if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type&A_MASK]) {
 219             arg[3].arg_type = chld[1].arg_type;
 220             arg[3].arg_ptr = chld[1].arg_ptr;
 221             arg[3].arg_len = chld[1].arg_len;
 222             free_arg(chld);
 223         }
 224         else {
 225             arg[3].arg_type = A_EXPR;
 226             arg[3].arg_ptr.arg_arg = chld;
 227         }
 228     }
 229     if (newlen >= 4 && (chld = arg4)) {
 230         if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type&A_MASK]) {
 231             arg[4].arg_type = chld[1].arg_type;
 232             arg[4].arg_ptr = chld[1].arg_ptr;
 233             arg[4].arg_len = chld[1].arg_len;
 234             free_arg(chld);
 235         }
 236         else {
 237             arg[4].arg_type = A_EXPR;
 238             arg[4].arg_ptr.arg_arg = chld;
 239         }
 240     }
 241     if (newlen >= 5 && (chld = arg5)) {
 242         if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type&A_MASK]) {
 243             arg[5].arg_type = chld[1].arg_type;
 244             arg[5].arg_ptr = chld[1].arg_ptr;
 245             arg[5].arg_len = chld[1].arg_len;
 246             free_arg(chld);
 247         }
 248         else {
 249             arg[5].arg_type = A_EXPR;
 250             arg[5].arg_ptr.arg_arg = chld;
 251         }
 252     }
 253     doarg = opargs[type];
 254     for (i = 1; i <= newlen; ++i) {
 255         if (!(doarg & 1))
 256             arg[i].arg_type |= A_DONT;
 257         if (doarg & 2)
 258             arg[i].arg_flags |= AF_ARYOK;
 259         doarg >>= 2;
 260     }
 261 #ifdef DEBUGGING
 262     if (debug & 16) {
 263         fprintf(stderr,"%lx <= make_op(%s",arg,opname[arg->arg_type]);
 264         if (arg1)
 265             fprintf(stderr,",%s=%lx",
 266                 argname[arg[1].arg_type&A_MASK],arg[1].arg_ptr.arg_arg);
 267         if (arg2)
 268             fprintf(stderr,",%s=%lx",
 269                 argname[arg[2].arg_type&A_MASK],arg[2].arg_ptr.arg_arg);
 270         if (arg3)
 271             fprintf(stderr,",%s=%lx",
 272                 argname[arg[3].arg_type&A_MASK],arg[3].arg_ptr.arg_arg);
 273         if (newlen >= 4)
 274             fprintf(stderr,",%s=%lx",
 275                 argname[arg[4].arg_type&A_MASK],arg[4].arg_ptr.arg_arg);
 276         if (newlen >= 5)
 277             fprintf(stderr,",%s=%lx",
 278                 argname[arg[5].arg_type&A_MASK],arg[5].arg_ptr.arg_arg);
 279         fprintf(stderr,")\n");
 280     }
 281 #endif
 282     evalstatic(arg);            /* see if we can consolidate anything */
 283     return arg;
 284 }
 285
 286 void
 287 evalstatic(arg)
 288 register ARG *arg;
 289 {
 290     register STR *str;
 291     register STR *s1;
 292     register STR *s2;
 293     double value;               /* must not be register */
 294     register char *tmps;
 295     int i;
 296     unsigned long tmplong;
 297     long tmp2;
 298     double exp(), log(), sqrt(), modf();
 299     char *crypt();
 300     double sin(), cos(), atan2(), pow();
 301
 302     if (!arg || !arg->arg_len)
 303         return;
 304
 305     if ((arg[1].arg_type == A_SINGLE || arg->arg_type == O_AELEM) &&
 306         (arg->arg_len == 1 || arg[2].arg_type == A_SINGLE) ) {
 307         str = Str_new(20,0);
 308         s1 = arg[1].arg_ptr.arg_str;
 309         if (arg->arg_len > 1)
 310             s2 = arg[2].arg_ptr.arg_str;
 311         else
 312             s2 = Nullstr;
 313         switch (arg->arg_type) {
 314         case O_AELEM:
 315             i = (int)str_gnum(s2);
 316             if (i < 32767 && i >= 0) {
 317                 arg->arg_type = O_ITEM;
 318                 arg->arg_len = 1;
 319                 arg[1].arg_type = A_ARYSTAB;    /* $abc[123] is hoistable now */
 320                 arg[1].arg_len = i;
 321                 str_free(s2);
 322             }
 323             /* FALL THROUGH */
 324         default:
 325             str_free(str);
 326             str = Nullstr;              /* can't be evaluated yet */
 327             break;
 328         case O_CONCAT:
 329             str_sset(str,s1);
 330             str_scat(str,s2);
 331             break;
 332         case O_REPEAT:
 333             i = (int)str_gnum(s2);
 334             tmps = str_get(s1);
 335             str_nset(str,"",0);
 336             STR_GROW(str, i * s1->str_cur + 1);
 337             repeatcpy(str->str_ptr, tmps, s1->str_cur, i);
 338             str->str_cur = i * s1->str_cur;
 339             str->str_ptr[str->str_cur] = '\0';
 340             break;
 341         case O_MULTIPLY:
 342             value = str_gnum(s1);
 343             str_numset(str,value * str_gnum(s2));
 344             break;
 345         case O_DIVIDE:
 346             value = str_gnum(s2);
 347             if (value == 0.0)
 348                 yyerror("Illegal division by constant zero");
 349             else
 350                 str_numset(str,str_gnum(s1) / value);
 351             break;
 352         case O_MODULO:
 353             tmplong = (unsigned long)str_gnum(s2);
 354             if (tmplong == 0L) {
 355                 yyerror("Illegal modulus of constant zero");
 356                 break;
 357             }
 358             tmp2 = (long)str_gnum(s1);
 359 #ifndef lint
 360             if (tmp2 >= 0)
 361                 str_numset(str,(double)(tmp2 % tmplong));
 362             else
 363                 str_numset(str,(double)((tmplong-((-tmp2 - 1) % tmplong)) - 1));
 364 #else
 365             tmp2 = tmp2;
 366 #endif
 367             break;
 368         case O_ADD:
 369             value = str_gnum(s1);
 370             str_numset(str,value + str_gnum(s2));
 371             break;
 372         case O_SUBTRACT:
 373             value = str_gnum(s1);
 374             str_numset(str,value - str_gnum(s2));
 375             break;
 376         case O_LEFT_SHIFT:
 377             value = str_gnum(s1);
 378             i = (int)str_gnum(s2);
 379 #ifndef lint
 380             str_numset(str,(double)(((long)value) << i));
 381 #endif
 382             break;
 383         case O_RIGHT_SHIFT:
 384             value = str_gnum(s1);
 385             i = (int)str_gnum(s2);
 386 #ifndef lint
 387             str_numset(str,(double)(((long)value) >> i));
 388 #endif
 389             break;
 390         case O_LT:
 391             value = str_gnum(s1);
 392             str_numset(str,(value < str_gnum(s2)) ? 1.0 : 0.0);
 393             break;
 394         case O_GT:
 395             value = str_gnum(s1);
 396             str_numset(str,(value > str_gnum(s2)) ? 1.0 : 0.0);
 397             break;
 398         case O_LE:
 399             value = str_gnum(s1);
 400             str_numset(str,(value <= str_gnum(s2)) ? 1.0 : 0.0);
 401             break;
 402         case O_GE:
 403             value = str_gnum(s1);
 404             str_numset(str,(value >= str_gnum(s2)) ? 1.0 : 0.0);
 405             break;
 406         case O_EQ:
 407             if (dowarn) {
 408                 if ((!s1->str_nok && !looks_like_number(s1)) ||
 409                     (!s2->str_nok && !looks_like_number(s2)) )
 410                     warn("Possible use of == on string value");
 411             }
 412             value = str_gnum(s1);
 413             str_numset(str,(value == str_gnum(s2)) ? 1.0 : 0.0);
 414             break;
 415         case O_NE:
 416             value = str_gnum(s1);
 417             str_numset(str,(value != str_gnum(s2)) ? 1.0 : 0.0);
 418             break;
 419         case O_NCMP:
 420             value = str_gnum(s1);
 421             value -= str_gnum(s2);
 422             if (value > 0.0)
 423                 value = 1.0;
 424             else if (value < 0.0)
 425                 value = -1.0;
 426             str_numset(str,value);
 427             break;
 428         case O_BIT_AND:
 429             value = str_gnum(s1);
 430 #ifndef lint
 431             str_numset(str,(double)(U_L(value) & U_L(str_gnum(s2))));
 432 #endif
 433             break;
 434         case O_XOR:
 435             value = str_gnum(s1);
 436 #ifndef lint
 437             str_numset(str,(double)(U_L(value) ^ U_L(str_gnum(s2))));
 438 #endif
 439             break;
 440         case O_BIT_OR:
 441             value = str_gnum(s1);
 442 #ifndef lint
 443             str_numset(str,(double)(U_L(value) | U_L(str_gnum(s2))));
 444 #endif
 445             break;
 446         case O_AND:
 447             if (str_true(s1))
 448                 str_sset(str,s2);
 449             else
 450                 str_sset(str,s1);
 451             break;
 452         case O_OR:
 453             if (str_true(s1))
 454                 str_sset(str,s1);
 455             else
 456                 str_sset(str,s2);
 457             break;
 458         case O_COND_EXPR:
 459             if ((arg[3].arg_type & A_MASK) != A_SINGLE) {
 460                 str_free(str);
 461                 str = Nullstr;
 462             }
 463             else {
 464                 if (str_true(s1))
 465                     str_sset(str,s2);
 466                 else
 467                     str_sset(str,arg[3].arg_ptr.arg_str);
 468                 str_free(arg[3].arg_ptr.arg_str);
 469             }
 470             break;
 471         case O_NEGATE:
 472             str_numset(str,(double)(-str_gnum(s1)));
 473             break;
 474         case O_NOT:
 475             str_numset(str,(double)(!str_true(s1)));
 476             break;
 477         case O_COMPLEMENT:
 478 #ifndef lint
 479             str_numset(str,(double)(~U_L(str_gnum(s1))));
 480 #endif
 481             break;
 482         case O_SIN:
 483             str_numset(str,sin(str_gnum(s1)));
 484             break;
 485         case O_COS:
 486             str_numset(str,cos(str_gnum(s1)));
 487             break;
 488         case O_ATAN2:
 489             value = str_gnum(s1);
 490             str_numset(str,atan2(value, str_gnum(s2)));
 491             break;
 492         case O_POW:
 493             value = str_gnum(s1);
 494             str_numset(str,pow(value, str_gnum(s2)));
 495             break;
 496         case O_LENGTH:
 497             str_numset(str, (double)str_len(s1));
 498             break;
 499         case O_SLT:
 500             str_numset(str,(double)(str_cmp(s1,s2) < 0));
 501             break;
 502         case O_SGT:
 503             str_numset(str,(double)(str_cmp(s1,s2) > 0));
 504             break;
 505         case O_SLE:
 506             str_numset(str,(double)(str_cmp(s1,s2) <= 0));
 507             break;
 508         case O_SGE:
 509             str_numset(str,(double)(str_cmp(s1,s2) >= 0));
 510             break;
 511         case O_SEQ:
 512             str_numset(str,(double)(str_eq(s1,s2)));
 513             break;
 514         case O_SNE:
 515             str_numset(str,(double)(!str_eq(s1,s2)));
 516             break;
 517         case O_SCMP:
 518             str_numset(str,(double)(str_cmp(s1,s2)));
 519             break;
 520         case O_CRYPT:
 521 #ifdef CRYPT
 522             tmps = str_get(s1);
 523             str_set(str,crypt(tmps,str_get(s2)));
 524 #else
 525             yyerror(
 526             "The crypt() function is unimplemented due to excessive paranoia.");
 527 #endif
 528             break;
 529         case O_EXP:
 530             str_numset(str,exp(str_gnum(s1)));
 531             break;
 532         case O_LOG:
 533             str_numset(str,log(str_gnum(s1)));
 534             break;
 535         case O_SQRT:
 536             str_numset(str,sqrt(str_gnum(s1)));
 537             break;
 538         case O_INT:
 539             value = str_gnum(s1);
 540             if (value >= 0.0)
 541                 (void)modf(value,&value);
 542             else {
 543                 (void)modf(-value,&value);
 544                 value = -value;
 545             }
 546             str_numset(str,value);
 547             break;
 548         case O_ORD:
 549 #ifndef I286
 550             str_numset(str,(double)(*str_get(s1)));
 551 #else
 552             {
 553                 int  zapc;
 554                 char *zaps;
 555
 556                 zaps = str_get(s1);
 557                 zapc = (int) *zaps;
 558                 str_numset(str,(double)(zapc));
 559             }
 560 #endif
 561             break;
 562         }
 563         if (str) {
 564             arg->arg_type = O_ITEM;     /* note arg1 type is already SINGLE */
 565             str_free(s1);
 566             str_free(s2);
 567             arg[1].arg_ptr.arg_str = str;
 568         }
 569     }
 570 }
 571
 572 ARG *
 573 l(arg)
 574 register ARG *arg;
 575 {
 576     register int i;
 577     register ARG *arg1;
 578     register ARG *arg2;
 579     SPAT *spat;
 580     int arghog = 0;
 581
 582     i = arg[1].arg_type & A_MASK;
 583
 584     arg->arg_flags |= AF_COMMON;        /* assume something in common */
 585                                         /* which forces us to copy things */
 586
 587     if (i == A_ARYLEN) {
 588         arg[1].arg_type = A_LARYLEN;
 589         return arg;
 590     }
 591     if (i == A_ARYSTAB) {
 592         arg[1].arg_type = A_LARYSTAB;
 593         return arg;
 594     }
 595
 596     /* see if it's an array reference */
 597
 598     if (i == A_EXPR || i == A_LEXPR) {
 599         arg1 = arg[1].arg_ptr.arg_arg;
 600
 601         if (arg1->arg_type == O_LIST || arg1->arg_type == O_ITEM) {
 602                                                 /* assign to list */
 603             if (arg->arg_len > 1) {
 604                 dehoist(arg,2);
 605                 arg2 = arg[2].arg_ptr.arg_arg;
 606                 if (nothing_in_common(arg1,arg2))
 607                     arg->arg_flags &= ~AF_COMMON;
 608                 if (arg->arg_type == O_ASSIGN) {
 609                     if (arg1->arg_flags & AF_LOCAL)
 610                         arg->arg_flags |= AF_LOCAL;
 611                     arg[1].arg_flags |= AF_ARYOK;
 612                     arg[2].arg_flags |= AF_ARYOK;
 613                 }
 614             }
 615             else if (arg->arg_type != O_CHOP)
 616                 arg->arg_type = O_ASSIGN;       /* possible local(); */
 617             for (i = arg1->arg_len; i >= 1; i--) {
 618                 switch (arg1[i].arg_type) {
 619                 case A_STAR: case A_LSTAR:
 620                     arg1[i].arg_type = A_LSTAR;
 621                     break;
 622                 case A_STAB: case A_LVAL:
 623                     arg1[i].arg_type = A_LVAL;
 624                     break;
 625                 case A_ARYLEN: case A_LARYLEN:
 626                     arg1[i].arg_type = A_LARYLEN;
 627                     break;
 628                 case A_ARYSTAB: case A_LARYSTAB:
 629                     arg1[i].arg_type = A_LARYSTAB;
 630                     break;
 631                 case A_EXPR: case A_LEXPR:
 632                     arg1[i].arg_type = A_LEXPR;
 633                     switch(arg1[i].arg_ptr.arg_arg->arg_type) {
 634                     case O_ARRAY: case O_LARRAY:
 635                         arg1[i].arg_ptr.arg_arg->arg_type = O_LARRAY;
 636                         arghog = 1;
 637                         break;
 638                     case O_AELEM: case O_LAELEM:
 639                         arg1[i].arg_ptr.arg_arg->arg_type = O_LAELEM;
 640                         break;
 641                     case O_HASH: case O_LHASH:
 642                         arg1[i].arg_ptr.arg_arg->arg_type = O_LHASH;
 643                         arghog = 1;
 644                         break;
 645                     case O_HELEM: case O_LHELEM:
 646                         arg1[i].arg_ptr.arg_arg->arg_type = O_LHELEM;
 647                         break;
 648                     case O_ASLICE: case O_LASLICE:
 649                         arg1[i].arg_ptr.arg_arg->arg_type = O_LASLICE;
 650                         break;
 651                     case O_HSLICE: case O_LHSLICE:
 652                         arg1[i].arg_ptr.arg_arg->arg_type = O_LHSLICE;
 653                         break;
 654                     default:
 655                         goto ill_item;
 656                     }
 657                     break;
 658                 default:
 659                   ill_item:
 660                     (void)sprintf(tokenbuf, "Illegal item (%s) as lvalue",
 661                       argname[arg1[i].arg_type&A_MASK]);
 662                     yyerror(tokenbuf);
 663                 }
 664             }
 665             if (arg->arg_len > 1) {
 666                 if (arg2->arg_type == O_SPLIT && !arg2[3].arg_type && !arghog) {
 667                     arg2[3].arg_type = A_SINGLE;
 668                     arg2[3].arg_ptr.arg_str =
 669                       str_nmake((double)arg1->arg_len + 1); /* limit split len*/
 670                 }
 671             }
 672         }
 673         else if (arg1->arg_type == O_AELEM || arg1->arg_type == O_LAELEM)
 674             if (arg->arg_type == O_DEFINED)
 675                 arg1->arg_type = O_AELEM;
 676             else
 677                 arg1->arg_type = O_LAELEM;
 678         else if (arg1->arg_type == O_ARRAY || arg1->arg_type == O_LARRAY) {
 679             arg1->arg_type = O_LARRAY;
 680             if (arg->arg_len > 1) {
 681                 dehoist(arg,2);
 682                 arg2 = arg[2].arg_ptr.arg_arg;
 683                 if (arg2->arg_type == O_SPLIT) { /* use split's builtin =?*/
 684                     spat = arg2[2].arg_ptr.arg_spat;
 685                     if (!(spat->spat_flags & SPAT_ONCE) &&
 686                       nothing_in_common(arg1,spat->spat_repl)) {
 687                         spat->spat_repl[1].arg_ptr.arg_stab =
 688                             arg1[1].arg_ptr.arg_stab;
 689                         spat->spat_flags |= SPAT_ONCE;
 690                         arg_free(arg1); /* recursive */
 691                         free_arg(arg);  /* non-recursive */
 692                         return arg2;    /* split has builtin assign */
 693                     }
 694                 }
 695                 else if (nothing_in_common(arg1,arg2))
 696                     arg->arg_flags &= ~AF_COMMON;
 697                 if (arg->arg_type == O_ASSIGN) {
 698                     arg[1].arg_flags |= AF_ARYOK;
 699                     arg[2].arg_flags |= AF_ARYOK;
 700                 }
 701             }
 702             else if (arg->arg_type == O_ASSIGN)
 703                 arg[1].arg_flags |= AF_ARYOK;
 704         }
 705         else if (arg1->arg_type == O_HELEM || arg1->arg_type == O_LHELEM)
 706             if (arg->arg_type == O_DEFINED)
 707                 arg1->arg_type = O_HELEM;       /* avoid creating one */
 708             else
 709                 arg1->arg_type = O_LHELEM;
 710         else if (arg1->arg_type == O_HASH || arg1->arg_type == O_LHASH) {
 711             arg1->arg_type = O_LHASH;
 712             if (arg->arg_len > 1) {
 713                 dehoist(arg,2);
 714                 arg2 = arg[2].arg_ptr.arg_arg;
 715                 if (nothing_in_common(arg1,arg2))
 716                     arg->arg_flags &= ~AF_COMMON;
 717                 if (arg->arg_type == O_ASSIGN) {
 718                     arg[1].arg_flags |= AF_ARYOK;
 719                     arg[2].arg_flags |= AF_ARYOK;
 720                 }
 721             }
 722             else if (arg->arg_type == O_ASSIGN)
 723                 arg[1].arg_flags |= AF_ARYOK;
 724         }
 725         else if (arg1->arg_type == O_ASLICE) {
 726             arg1->arg_type = O_LASLICE;
 727             if (arg->arg_type == O_ASSIGN) {
 728                 dehoist(arg,2);
 729                 arg[1].arg_flags |= AF_ARYOK;
 730                 arg[2].arg_flags |= AF_ARYOK;
 731             }
 732         }
 733         else if (arg1->arg_type == O_HSLICE) {
 734             arg1->arg_type = O_LHSLICE;
 735             if (arg->arg_type == O_ASSIGN) {
 736                 dehoist(arg,2);
 737                 arg[1].arg_flags |= AF_ARYOK;
 738                 arg[2].arg_flags |= AF_ARYOK;
 739             }
 740         }
 741         else if ((arg->arg_type == O_DEFINED || arg->arg_type == O_UNDEF) &&
 742           (arg1->arg_type == (perldb ? O_DBSUBR : O_SUBR)) ) {
 743             arg[1].arg_type |= A_DONT;
 744         }
 745         else if (arg1->arg_type == O_SUBSTR || arg1->arg_type == O_VEC) {
 746             (void)l(arg1);
 747             Renewc(arg1->arg_ptr.arg_str, 1, struct lstring, STR);
 748                         /* grow string struct to hold an lstring struct */
 749         }
 750         else if (arg1->arg_type == O_ASSIGN) {
 751             if (arg->arg_type == O_CHOP)
 752                 arg[1].arg_flags &= ~AF_ARYOK;  /* grandfather chop idiom */
 753         }
 754         else {
 755             (void)sprintf(tokenbuf,
 756               "Illegal expression (%s) as lvalue",opname[arg1->arg_type]);
 757             yyerror(tokenbuf);
 758         }
 759         arg[1].arg_type = A_LEXPR | (arg[1].arg_type & A_DONT);
 760         if (arg->arg_type == O_ASSIGN && (arg1[1].arg_flags & AF_ARYOK)) {
 761             arg[1].arg_flags |= AF_ARYOK;
 762             if (arg->arg_len > 1)
 763                 arg[2].arg_flags |= AF_ARYOK;
 764         }
 765 #ifdef DEBUGGING
 766         if (debug & 16)
 767             fprintf(stderr,"lval LEXPR\n");
 768 #endif
 769         return arg;
 770     }
 771     if (i == A_STAR || i == A_LSTAR) {
 772         arg[1].arg_type = A_LSTAR | (arg[1].arg_type & A_DONT);
 773         return arg;
 774     }
 775
 776     /* not an array reference, should be a register name */
 777
 778     if (i != A_STAB && i != A_LVAL) {
 779         (void)sprintf(tokenbuf,
 780           "Illegal item (%s) as lvalue",argname[arg[1].arg_type&A_MASK]);
 781         yyerror(tokenbuf);
 782     }
 783     arg[1].arg_type = A_LVAL | (arg[1].arg_type & A_DONT);
 784 #ifdef DEBUGGING
 785     if (debug & 16)
 786         fprintf(stderr,"lval LVAL\n");
 787 #endif
 788     return arg;
 789 }
 790
 791 ARG *
 792 fixl(type,arg)
 793 int type;
 794 ARG *arg;
 795 {
 796     if (type == O_DEFINED || type == O_UNDEF) {
 797         if (arg->arg_type != O_ITEM)
 798             arg = hide_ary(arg);
 799         if (arg->arg_type == O_ITEM) {
 800             type = arg[1].arg_type & A_MASK;
 801             if (type == A_EXPR || type == A_LEXPR)
 802                 arg[1].arg_type = A_LEXPR|A_DONT;
 803         }
 804     }
 805     return arg;
 806 }
 807
 808 dehoist(arg,i)
 809 ARG *arg;
 810 {
 811     ARG *tmparg;
 812
 813     if (arg[i].arg_type != A_EXPR) {    /* dehoist */
 814         tmparg = make_op(O_ITEM,1,Nullarg,Nullarg,Nullarg);
 815         tmparg[1] = arg[i];
 816         arg[i].arg_ptr.arg_arg = tmparg;
 817         arg[i].arg_type = A_EXPR;
 818     }
 819 }
 820
 821 ARG *
 822 addflags(i,flags,arg)
 823 register ARG *arg;
 824 {
 825     arg[i].arg_flags |= flags;
 826     return arg;
 827 }
 828
 829 ARG *
 830 hide_ary(arg)
 831 ARG *arg;
 832 {
 833     if (arg->arg_type == O_ARRAY || arg->arg_type == O_HASH)
 834         return make_op(O_ITEM,1,arg,Nullarg,Nullarg);
 835     return arg;
 836 }
 837
 838 /* maybe do a join on multiple array dimensions */
 839
 840 ARG *
 841 jmaybe(arg)
 842 register ARG *arg;
 843 {
 844     if (arg && arg->arg_type == O_COMMA) {
 845         arg = listish(arg);
 846         arg = make_op(O_JOIN, 2,
 847             stab2arg(A_STAB,stabent(";",TRUE)),
 848             make_list(arg),
 849             Nullarg);
 850     }
 851     return arg;
 852 }
 853
 854 ARG *
 855 make_list(arg)
 856 register ARG *arg;
 857 {
 858     register int i;
 859     register ARG *node;
 860     register ARG *nxtnode;
 861     register int j;
 862     STR *tmpstr;
 863
 864     if (!arg) {
 865         arg = op_new(0);
 866         arg->arg_type = O_LIST;
 867     }
 868     if (arg->arg_type != O_COMMA) {
 869         if (arg->arg_type != O_ARRAY)
 870             arg->arg_flags |= AF_LISTISH;       /* see listish() below */
 871         return arg;
 872     }
 873     for (i = 2, node = arg; ; i++) {
 874         if (node->arg_len < 2)
 875             break;
 876         if (node[1].arg_type != A_EXPR)
 877             break;
 878         node = node[1].arg_ptr.arg_arg;
 879         if (node->arg_type != O_COMMA)
 880             break;
 881     }
 882     if (i > 2) {
 883         node = arg;
 884         arg = op_new(i);
 885         tmpstr = arg->arg_ptr.arg_str;
 886 #ifdef STRUCTCOPY
 887         *arg = *node;           /* copy everything except the STR */
 888 #else
 889         (void)bcopy((char *)node, (char *)arg, sizeof(ARG));
 890 #endif
 891         arg->arg_ptr.arg_str = tmpstr;
 892         for (j = i; ; ) {
 893 #ifdef STRUCTCOPY
 894             arg[j] = node[2];
 895 #else
 896             (void)bcopy((char *)(node+2), (char *)(arg+j), sizeof(ARG));
 897 #endif
 898             arg[j].arg_flags |= AF_ARYOK;
 899             --j;                /* Bug in Xenix compiler */
 900             if (j < 2) {
 901 #ifdef STRUCTCOPY
 902                 arg[1] = node[1];
 903 #else
 904                 (void)bcopy((char *)(node+1), (char *)(arg+1), sizeof(ARG));
 905 #endif
 906                 free_arg(node);
 907                 break;
 908             }
 909             nxtnode = node[1].arg_ptr.arg_arg;
 910             free_arg(node);
 911             node = nxtnode;
 912         }
 913     }
 914     arg[1].arg_flags |= AF_ARYOK;
 915     arg[2].arg_flags |= AF_ARYOK;
 916     arg->arg_type = O_LIST;
 917     arg->arg_len = i;
 918     return arg;
 919 }
 920
 921 /* turn a single item into a list */
 922
 923 ARG *
 924 listish(arg)
 925 ARG *arg;
 926 {
 927     if (arg->arg_flags & AF_LISTISH)
 928         arg = make_op(O_LIST,1,arg,Nullarg,Nullarg);
 929     return arg;
 930 }
 931
 932 ARG *
 933 maybelistish(optype, arg)
 934 int optype;
 935 ARG *arg;
 936 {
 937     ARG *tmparg = arg;
 938
 939     if (optype == O_RETURN && arg->arg_type == O_ITEM &&
 940       arg[1].arg_type == A_EXPR && (tmparg = arg[1].arg_ptr.arg_arg) &&
 941       ((tmparg->arg_flags & AF_LISTISH) || (tmparg->arg_type == O_ARRAY) )) {
 942         tmparg = listish(tmparg);
 943         free_arg(arg);
 944         arg = tmparg;
 945     }
 946     else if (optype == O_PRTF ||
 947       (arg->arg_type == O_ASLICE || arg->arg_type == O_HSLICE ||
 948        arg->arg_type == O_F_OR_R) )
 949         arg = listish(arg);
 950     return arg;
 951 }
 952
 953 /* mark list of local variables */
 954
 955 ARG *
 956 localize(arg)
 957 ARG *arg;
 958 {
 959     arg->arg_flags |= AF_LOCAL;
 960     return arg;
 961 }
 962
 963 ARG *
 964 rcatmaybe(arg)
 965 ARG *arg;
 966 {
 967     if (arg->arg_type == O_CONCAT && arg[2].arg_type == A_READ) {
 968         arg->arg_type = O_RCAT;
 969         arg[2].arg_type = arg[2].arg_ptr.arg_arg[1].arg_type;
 970         arg[2].arg_ptr = arg[2].arg_ptr.arg_arg[1].arg_ptr;
 971         free_arg(arg[2].arg_ptr.arg_arg);
 972     }
 973     return arg;
 974 }
 975
 976 ARG *
 977 stab2arg(atype,stab)
 978 int atype;
 979 register STAB *stab;
 980 {
 981     register ARG *arg;
 982
 983     arg = op_new(1);
 984     arg->arg_type = O_ITEM;
 985     arg[1].arg_type = atype;
 986     arg[1].arg_ptr.arg_stab = stab;
 987     return arg;
 988 }
 989
 990 ARG *
 991 cval_to_arg(cval)
 992 register char *cval;
 993 {
 994     register ARG *arg;
 995
 996     arg = op_new(1);
 997     arg->arg_type = O_ITEM;
 998     arg[1].arg_type = A_SINGLE;
 999     arg[1].arg_ptr.arg_str = str_make(cval,0);
1000     Safefree(cval);
1001     return arg;
1002 }
1003
1004 ARG *
1005 op_new(numargs)
1006 int numargs;
1007 {
1008     register ARG *arg;
1009
1010     Newz(203,arg, numargs + 1, ARG);
1011     arg->arg_ptr.arg_str = Str_new(21,0);
1012     arg->arg_len = numargs;
1013     return arg;
1014 }
1015
1016 void
1017 free_arg(arg)
1018 ARG *arg;
1019 {
1020     str_free(arg->arg_ptr.arg_str);
1021     Safefree(arg);
1022 }
1023
1024 ARG *
1025 make_match(type,expr,spat)
1026 int type;
1027 ARG *expr;
1028 SPAT *spat;
1029 {
1030     register ARG *arg;
1031
1032     arg = make_op(type,2,expr,Nullarg,Nullarg);
1033
1034     arg[2].arg_type = A_SPAT|A_DONT;
1035     arg[2].arg_ptr.arg_spat = spat;
1036 #ifdef DEBUGGING
1037     if (debug & 16)
1038         fprintf(stderr,"make_match SPAT=%lx\n",(long)spat);
1039 #endif
1040
1041     if (type == O_SUBST || type == O_NSUBST) {
1042         if (arg[1].arg_type != A_STAB) {
1043             yyerror("Illegal lvalue");
1044         }
1045         arg[1].arg_type = A_LVAL;
1046     }
1047     return arg;
1048 }
1049
1050 ARG *
1051 cmd_to_arg(cmd)
1052 CMD *cmd;
1053 {
1054     register ARG *arg;
1055
1056     arg = op_new(1);
1057     arg->arg_type = O_ITEM;
1058     arg[1].arg_type = A_CMD;
1059     arg[1].arg_ptr.arg_cmd = cmd;
1060     return arg;
1061 }
1062
1063 /* Check two expressions to see if there is any identifier in common */
1064
1065 static int
1066 nothing_in_common(arg1,arg2)
1067 ARG *arg1;
1068 ARG *arg2;
1069 {
1070     static int thisexpr = 0;    /* I don't care if this wraps */
1071
1072     thisexpr++;
1073     if (arg_common(arg1,thisexpr,1))
1074         return 0;       /* hit eval or do {} */
1075     stab_lastexpr(defstab) = thisexpr;          /* pretend to hit @_ */
1076     if (arg_common(arg2,thisexpr,0))
1077         return 0;       /* hit identifier again */
1078     return 1;
1079 }
1080
1081 /* Recursively descend an expression and mark any identifier or check
1082  * it to see if it was marked already.
1083  */
1084
1085 static int
1086 arg_common(arg,exprnum,marking)
1087 register ARG *arg;
1088 int exprnum;
1089 int marking;
1090 {
1091     register int i;
1092
1093     if (!arg)
1094         return 0;
1095     for (i = arg->arg_len; i >= 1; i--) {
1096         switch (arg[i].arg_type & A_MASK) {
1097         case A_NULL:
1098             break;
1099         case A_LEXPR:
1100         case A_EXPR:
1101             if (arg_common(arg[i].arg_ptr.arg_arg,exprnum,marking))
1102                 return 1;
1103             break;
1104         case A_CMD:
1105             return 1;           /* assume hanky panky */
1106         case A_STAR:
1107         case A_LSTAR:
1108         case A_STAB:
1109         case A_LVAL:
1110         case A_ARYLEN:
1111         case A_LARYLEN:
1112             if (marking)
1113                 stab_lastexpr(arg[i].arg_ptr.arg_stab) = exprnum;
1114             else if (stab_lastexpr(arg[i].arg_ptr.arg_stab) == exprnum)
1115                 return 1;
1116             break;
1117         case A_DOUBLE:
1118         case A_BACKTICK:
1119             {
1120                 register char *s = arg[i].arg_ptr.arg_str->str_ptr;
1121                 register char *send = s + arg[i].arg_ptr.arg_str->str_cur;
1122                 register STAB *stab;
1123
1124                 while (*s) {
1125                     if (*s == '$' && s[1]) {
1126                         s = scanreg(s,send,tokenbuf);
1127                         stab = stabent(tokenbuf,TRUE);
1128                         if (marking)
1129                             stab_lastexpr(stab) = exprnum;
1130                         else if (stab_lastexpr(stab) == exprnum)
1131                             return 1;
1132                         continue;
1133                     }
1134                     else if (*s == '\\' && s[1])
1135                         s++;
1136                     s++;
1137                 }
1138             }
1139             break;
1140         case A_SPAT:
1141             if (spat_common(arg[i].arg_ptr.arg_spat,exprnum,marking))
1142                 return 1;
1143             break;
1144         case A_READ:
1145         case A_INDREAD:
1146         case A_GLOB:
1147         case A_WORD:
1148         case A_SINGLE:
1149             break;
1150         }
1151     }
1152     switch (arg->arg_type) {
1153     case O_ARRAY:
1154     case O_LARRAY:
1155         if ((arg[1].arg_type & A_MASK) == A_STAB)
1156             (void)aadd(arg[1].arg_ptr.arg_stab);
1157         break;
1158     case O_HASH:
1159     case O_LHASH:
1160         if ((arg[1].arg_type & A_MASK) == A_STAB)
1161             (void)hadd(arg[1].arg_ptr.arg_stab);
1162         break;
1163     case O_EVAL:
1164     case O_SUBR:
1165     case O_DBSUBR:
1166         return 1;
1167     }
1168     return 0;
1169 }
1170
1171 static int
1172 spat_common(spat,exprnum,marking)
1173 register SPAT *spat;
1174 int exprnum;
1175 int marking;
1176 {
1177     if (spat->spat_runtime)
1178         if (arg_common(spat->spat_runtime,exprnum,marking))
1179             return 1;
1180     if (spat->spat_repl) {
1181         if (arg_common(spat->spat_repl,exprnum,marking))
1182             return 1;
1183     }
1184     return 0;
1185 }