dolist.c

   1 /* $RCSfile: dolist.c,v $$Revision: 4.0.1.5 $$Date: 92/06/08 13:13:27 $
   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:        dolist.c,v $
   9  * Revision 4.0.1.5  92/06/08  13:13:27  lwall
  10  * patch20: g pattern modifer sometimes returned extra values
  11  * patch20: m/$pattern/g didn't work
  12  * patch20: pattern modifiers i and o didn't interact right
  13  * patch20: @ in unpack failed too often
  14  * patch20: Perl now distinguishes overlapped copies from non-overlapped
  15  * patch20: slice on null list in scalar context returned random value
  16  * patch20: splice with negative offset didn't work with $[ = 1
  17  * patch20: fixed some memory leaks in splice
  18  * patch20: scalar keys %array now counts keys for you
  19  *
  20  * Revision 4.0.1.4  91/11/11  16:33:19  lwall
  21  * patch19: added little-endian pack/unpack options
  22  * patch19: sort $subname was busted by changes in 4.018
  23  *
  24  * Revision 4.0.1.3  91/11/05  17:07:02  lwall
  25  * patch11: prepared for ctype implementations that don't define isascii()
  26  * patch11: /$foo/o optimizer could access deallocated data
  27  * patch11: certain optimizations of //g in array context returned too many values
  28  * patch11: regexp with no parens in array context returned wacky $`, $& and $'
  29  * patch11: $' not set right on some //g
  30  * patch11: added some support for 64-bit integers
  31  * patch11: grep of a split lost its values
  32  * patch11: added sort {} LIST
  33  * patch11: multiple reallocations now avoided in 1 .. 100000
  34  *
  35  * Revision 4.0.1.2  91/06/10  01:22:15  lwall
  36  * patch10: //g only worked first time through
  37  *
  38  * Revision 4.0.1.1  91/06/07  10:58:28  lwall
  39  * patch4: new copyright notice
  40  * patch4: added global modifier for pattern matches
  41  * patch4: // wouldn't use previous pattern if it started with a null character
  42  * patch4: //o and s///o now optimize themselves fully at runtime
  43  * patch4: $` was busted inside s///
  44  * patch4: caller($arg) didn't work except under debugger
  45  *
  46  * Revision 4.0  91/03/20  01:08:03  lwall
  47  * 4.0 baseline.
  48  *
  49  */
  50
  51 #include "EXTERN.h"
  52 #include "perl.h"
  53
  54 static int sortcmp();
  55 static int sortsub();
  56
  57 #ifdef BUGGY_MSC
  58  #pragma function(memcmp)
  59 #endif /* BUGGY_MSC */
  60
  61 int
  62 do_match(str,arg,gimme,arglast)
  63 STR *str;
  64 register ARG *arg;
  65 int gimme;
  66 int *arglast;
  67 {
  68     register STR **st = stack->ary_array;
  69     register SPAT *spat = arg[2].arg_ptr.arg_spat;
  70     register char *t;
  71     register int sp = arglast[0] + 1;
  72     STR *srchstr = st[sp];
  73     register char *s = str_get(st[sp]);
  74     char *strend = s + st[sp]->str_cur;
  75     STR *tmpstr;
  76     char *myhint = hint;
  77     int global;
  78     int safebase;
  79     char *truebase = s;
  80     register REGEXP *rx = spat->spat_regexp;
  81
  82     hint = Nullch;
  83     if (!spat) {
  84         if (gimme == G_ARRAY)
  85             return --sp;
  86         str_set(str,Yes);
  87         STABSET(str);
  88         st[sp] = str;
  89         return sp;
  90     }
  91     global = spat->spat_flags & SPAT_GLOBAL;
  92     safebase = (gimme == G_ARRAY) || global;
  93     if (!s)
  94         fatal("panic: do_match");
  95     if (spat->spat_flags & SPAT_USED) {
  96 #ifdef DEBUGGING
  97         if (debug & 8)
  98             deb("2.SPAT USED\n");
  99 #endif
 100         if (gimme == G_ARRAY)
 101             return --sp;
 102         str_set(str,No);
 103         STABSET(str);
 104         st[sp] = str;
 105         return sp;
 106     }
 107     --sp;
 108     if (spat->spat_runtime) {
 109         nointrp = "|)";
 110         sp = eval(spat->spat_runtime,G_SCALAR,sp);
 111         st = stack->ary_array;
 112         t = str_get(tmpstr = st[sp--]);
 113         nointrp = "";
 114 #ifdef DEBUGGING
 115         if (debug & 8)
 116             deb("2.SPAT /%s/\n",t);
 117 #endif
 118         if (!global && rx)
 119             regfree(rx);
 120         spat->spat_regexp = Null(REGEXP*);      /* crucial if regcomp aborts */
 121         spat->spat_regexp = regcomp(t,t+tmpstr->str_cur,
 122             spat->spat_flags & SPAT_FOLD);
 123         if (!spat->spat_regexp->prelen && lastspat)
 124             spat = lastspat;
 125         if (spat->spat_flags & SPAT_KEEP) {
 126             if (!(spat->spat_flags & SPAT_FOLD))
 127                 scanconst(spat,spat->spat_regexp->precomp,
 128                     spat->spat_regexp->prelen);
 129             if (spat->spat_runtime)
 130                 arg_free(spat->spat_runtime);   /* it won't change, so */
 131             spat->spat_runtime = Nullarg;       /* no point compiling again */
 132             hoistmust(spat);
 133             if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) {
 134                 curcmd->c_flags &= ~CF_OPTIMIZE;
 135                 opt_arg(curcmd, 1, curcmd->c_type == C_EXPR);
 136             }
 137         }
 138         if (global) {
 139             if (rx) {
 140                 if (rx->startp[0]) {
 141                     s = rx->endp[0];
 142                     if (s == rx->startp[0])
 143                         s++;
 144                     if (s > strend) {
 145                         regfree(rx);
 146                         rx = spat->spat_regexp;
 147                         goto nope;
 148                     }
 149                 }
 150                 regfree(rx);
 151             }
 152         }
 153         else if (!spat->spat_regexp->nparens)
 154             gimme = G_SCALAR;                   /* accidental array context? */
 155         rx = spat->spat_regexp;
 156         if (regexec(rx, s, strend, s, 0,
 157           srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
 158           safebase)) {
 159             if (rx->subbase || global)
 160                 curspat = spat;
 161             lastspat = spat;
 162             goto gotcha;
 163         }
 164         else {
 165             if (gimme == G_ARRAY)
 166                 return sp;
 167             str_sset(str,&str_no);
 168             STABSET(str);
 169             st[++sp] = str;
 170             return sp;
 171         }
 172     }
 173     else {
 174 #ifdef DEBUGGING
 175         if (debug & 8) {
 176             char ch;
 177
 178             if (spat->spat_flags & SPAT_ONCE)
 179                 ch = '?';
 180             else
 181                 ch = '/';
 182             deb("2.SPAT %c%s%c\n",ch,rx->precomp,ch);
 183         }
 184 #endif
 185         if (!rx->prelen && lastspat) {
 186             spat = lastspat;
 187             rx = spat->spat_regexp;
 188         }
 189         t = s;
 190     play_it_again:
 191         if (global && rx->startp[0]) {
 192             t = s = rx->endp[0];
 193             if (s == rx->startp[0])
 194                 s++,t++;
 195             if (s > strend)
 196                 goto nope;
 197         }
 198         if (myhint) {
 199             if (myhint < s || myhint > strend)
 200                 fatal("panic: hint in do_match");
 201             s = myhint;
 202             if (rx->regback >= 0) {
 203                 s -= rx->regback;
 204                 if (s < t)
 205                     s = t;
 206             }
 207             else
 208                 s = t;
 209         }
 210         else if (spat->spat_short) {
 211             if (spat->spat_flags & SPAT_SCANFIRST) {
 212                 if (srchstr->str_pok & SP_STUDIED) {
 213                     if (screamfirst[spat->spat_short->str_rare] < 0)
 214                         goto nope;
 215                     else if (!(s = screaminstr(srchstr,spat->spat_short)))
 216                         goto nope;
 217                     else if (spat->spat_flags & SPAT_ALL)
 218                         goto yup;
 219                 }
 220 #ifndef lint
 221                 else if (!(s = fbminstr((unsigned char*)s,
 222                   (unsigned char*)strend, spat->spat_short)))
 223                     goto nope;
 224 #endif
 225                 else if (spat->spat_flags & SPAT_ALL)
 226                     goto yup;
 227                 if (s && rx->regback >= 0) {
 228                     ++spat->spat_short->str_u.str_useful;
 229                     s -= rx->regback;
 230                     if (s < t)
 231                         s = t;
 232                 }
 233                 else
 234                     s = t;
 235             }
 236             else if (!multiline && (*spat->spat_short->str_ptr != *s ||
 237               bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) ))
 238                 goto nope;
 239             if (--spat->spat_short->str_u.str_useful < 0) {
 240                 str_free(spat->spat_short);
 241                 spat->spat_short = Nullstr;     /* opt is being useless */
 242             }
 243         }
 244         if (!rx->nparens && !global) {
 245             gimme = G_SCALAR;                   /* accidental array context? */
 246             safebase = FALSE;
 247         }
 248         if (regexec(rx, s, strend, truebase, 0,
 249           srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
 250           safebase)) {
 251             if (rx->subbase || global)
 252                 curspat = spat;
 253             lastspat = spat;
 254             if (spat->spat_flags & SPAT_ONCE)
 255                 spat->spat_flags |= SPAT_USED;
 256             goto gotcha;
 257         }
 258         else {
 259             if (global)
 260                 rx->startp[0] = Nullch;
 261             if (gimme == G_ARRAY)
 262                 return sp;
 263             str_sset(str,&str_no);
 264             STABSET(str);
 265             st[++sp] = str;
 266             return sp;
 267         }
 268     }
 269     /*NOTREACHED*/
 270
 271   gotcha:
 272     if (gimme == G_ARRAY) {
 273         int iters, i, len;
 274
 275         iters = rx->nparens;
 276         if (global && !iters)
 277             i = 1;
 278         else
 279             i = 0;
 280         if (sp + iters + i >= stack->ary_max) {
 281             astore(stack,sp + iters + i, Nullstr);
 282             st = stack->ary_array;              /* possibly realloced */
 283         }
 284
 285         for (i = !i; i <= iters; i++) {
 286             st[++sp] = str_mortal(&str_no);
 287             /*SUPPRESS 560*/
 288             if (s = rx->startp[i]) {
 289                 len = rx->endp[i] - s;
 290                 if (len > 0)
 291                     str_nset(st[sp],s,len);
 292             }
 293         }
 294         if (global) {
 295             truebase = rx->subbeg;
 296             goto play_it_again;
 297         }
 298         return sp;
 299     }
 300     else {
 301         str_sset(str,&str_yes);
 302         STABSET(str);
 303         st[++sp] = str;
 304         return sp;
 305     }
 306
 307 yup:
 308     ++spat->spat_short->str_u.str_useful;
 309     lastspat = spat;
 310     if (spat->spat_flags & SPAT_ONCE)
 311         spat->spat_flags |= SPAT_USED;
 312     if (global) {
 313         rx->subbeg = t;
 314         rx->subend = strend;
 315         rx->startp[0] = s;
 316         rx->endp[0] = s + spat->spat_short->str_cur;
 317         curspat = spat;
 318         goto gotcha;
 319     }
 320     if (sawampersand) {
 321         char *tmps;
 322
 323         if (rx->subbase)
 324             Safefree(rx->subbase);
 325         tmps = rx->subbase = nsavestr(t,strend-t);
 326         rx->subbeg = tmps;
 327         rx->subend = tmps + (strend-t);
 328         tmps = rx->startp[0] = tmps + (s - t);
 329         rx->endp[0] = tmps + spat->spat_short->str_cur;
 330         curspat = spat;
 331     }
 332     str_sset(str,&str_yes);
 333     STABSET(str);
 334     st[++sp] = str;
 335     return sp;
 336
 337 nope:
 338     rx->startp[0] = Nullch;
 339     if (spat->spat_short)
 340         ++spat->spat_short->str_u.str_useful;
 341     if (gimme == G_ARRAY)
 342         return sp;
 343     str_sset(str,&str_no);
 344     STABSET(str);
 345     st[++sp] = str;
 346     return sp;
 347 }
 348
 349 #ifdef BUGGY_MSC
 350  #pragma intrinsic(memcmp)
 351 #endif /* BUGGY_MSC */
 352
 353 int
 354 do_split(str,spat,limit,gimme,arglast)
 355 STR *str;
 356 register SPAT *spat;
 357 register int limit;
 358 int gimme;
 359 int *arglast;
 360 {
 361     register ARRAY *ary = stack;
 362     STR **st = ary->ary_array;
 363     register int sp = arglast[0] + 1;
 364     register char *s = str_get(st[sp]);
 365     char *strend = s + st[sp--]->str_cur;
 366     register STR *dstr;
 367     register char *m;
 368     int iters = 0;
 369     int maxiters = (strend - s) + 10;
 370     int i;
 371     char *orig;
 372     int origlimit = limit;
 373     int realarray = 0;
 374
 375     if (!spat || !s)
 376         fatal("panic: do_split");
 377     else if (spat->spat_runtime) {
 378         nointrp = "|)";
 379         sp = eval(spat->spat_runtime,G_SCALAR,sp);
 380         st = stack->ary_array;
 381         m = str_get(dstr = st[sp--]);
 382         nointrp = "";
 383         if (*m == ' ' && dstr->str_cur == 1) {
 384             str_set(dstr,"\\s+");
 385             m = dstr->str_ptr;
 386             spat->spat_flags |= SPAT_SKIPWHITE;
 387         }
 388         if (spat->spat_regexp) {
 389             regfree(spat->spat_regexp);
 390             spat->spat_regexp = Null(REGEXP*);  /* avoid possible double free */
 391         }
 392         spat->spat_regexp = regcomp(m,m+dstr->str_cur,
 393             spat->spat_flags & SPAT_FOLD);
 394         if (spat->spat_flags & SPAT_KEEP ||
 395             (spat->spat_runtime->arg_type == O_ITEM &&
 396               (spat->spat_runtime[1].arg_type & A_MASK) == A_SINGLE) ) {
 397             arg_free(spat->spat_runtime);       /* it won't change, so */
 398             spat->spat_runtime = Nullarg;       /* no point compiling again */
 399         }
 400     }
 401 #ifdef DEBUGGING
 402     if (debug & 8) {
 403         deb("2.SPAT /%s/\n",spat->spat_regexp->precomp);
 404     }
 405 #endif
 406     ary = stab_xarray(spat->spat_repl[1].arg_ptr.arg_stab);
 407     if (ary && (gimme != G_ARRAY || (spat->spat_flags & SPAT_ONCE))) {
 408         realarray = 1;
 409         if (!(ary->ary_flags & ARF_REAL)) {
 410             ary->ary_flags |= ARF_REAL;
 411             for (i = ary->ary_fill; i >= 0; i--)
 412                 ary->ary_array[i] = Nullstr;    /* don't free mere refs */
 413         }
 414         ary->ary_fill = -1;
 415         sp = -1;        /* temporarily switch stacks */
 416     }
 417     else
 418         ary = stack;
 419     orig = s;
 420     if (spat->spat_flags & SPAT_SKIPWHITE) {
 421         while (isSPACE(*s))
 422             s++;
 423     }
 424     if (!limit)
 425         limit = maxiters + 2;
 426     if (strEQ("\\s+",spat->spat_regexp->precomp)) {
 427         while (--limit) {
 428             /*SUPPRESS 530*/
 429             for (m = s; m < strend && !isSPACE(*m); m++) ;
 430             if (m >= strend)
 431                 break;
 432             dstr = Str_new(30,m-s);
 433             str_nset(dstr,s,m-s);
 434             if (!realarray)
 435                 str_2mortal(dstr);
 436             (void)astore(ary, ++sp, dstr);
 437             /*SUPPRESS 530*/
 438             for (s = m + 1; s < strend && isSPACE(*s); s++) ;
 439         }
 440     }
 441     else if (strEQ("^",spat->spat_regexp->precomp)) {
 442         while (--limit) {
 443             /*SUPPRESS 530*/
 444             for (m = s; m < strend && *m != '\n'; m++) ;
 445             m++;
 446             if (m >= strend)
 447                 break;
 448             dstr = Str_new(30,m-s);
 449             str_nset(dstr,s,m-s);
 450             if (!realarray)
 451                 str_2mortal(dstr);
 452             (void)astore(ary, ++sp, dstr);
 453             s = m;
 454         }
 455     }
 456     else if (spat->spat_short) {
 457         i = spat->spat_short->str_cur;
 458         if (i == 1) {
 459             int fold = (spat->spat_flags & SPAT_FOLD);
 460
 461             i = *spat->spat_short->str_ptr;
 462             if (fold && isUPPER(i))
 463                 i = tolower(i);
 464             while (--limit) {
 465                 if (fold) {
 466                     for ( m = s;
 467                           m < strend && *m != i &&
 468                             (!isUPPER(*m) || tolower(*m) != i);
 469                           m++)                  /*SUPPRESS 530*/
 470                         ;
 471                 }
 472                 else                            /*SUPPRESS 530*/
 473                     for (m = s; m < strend && *m != i; m++) ;
 474                 if (m >= strend)
 475                     break;
 476                 dstr = Str_new(30,m-s);
 477                 str_nset(dstr,s,m-s);
 478                 if (!realarray)
 479                     str_2mortal(dstr);
 480                 (void)astore(ary, ++sp, dstr);
 481                 s = m + 1;
 482             }
 483         }
 484         else {
 485 #ifndef lint
 486             while (s < strend && --limit &&
 487               (m=fbminstr((unsigned char*)s, (unsigned char*)strend,
 488                     spat->spat_short)) )
 489 #endif
 490             {
 491                 dstr = Str_new(31,m-s);
 492                 str_nset(dstr,s,m-s);
 493                 if (!realarray)
 494                     str_2mortal(dstr);
 495                 (void)astore(ary, ++sp, dstr);
 496                 s = m + i;
 497             }
 498         }
 499     }
 500     else {
 501         maxiters += (strend - s) * spat->spat_regexp->nparens;
 502         while (s < strend && --limit &&
 503             regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr, TRUE) ) {
 504             if (spat->spat_regexp->subbase
 505               && spat->spat_regexp->subbase != orig) {
 506                 m = s;
 507                 s = orig;
 508                 orig = spat->spat_regexp->subbase;
 509                 s = orig + (m - s);
 510                 strend = s + (strend - m);
 511             }
 512             m = spat->spat_regexp->startp[0];
 513             dstr = Str_new(32,m-s);
 514             str_nset(dstr,s,m-s);
 515             if (!realarray)
 516                 str_2mortal(dstr);
 517             (void)astore(ary, ++sp, dstr);
 518             if (spat->spat_regexp->nparens) {
 519                 for (i = 1; i <= spat->spat_regexp->nparens; i++) {
 520                     s = spat->spat_regexp->startp[i];
 521                     m = spat->spat_regexp->endp[i];
 522                     dstr = Str_new(33,m-s);
 523                     str_nset(dstr,s,m-s);
 524                     if (!realarray)
 525                         str_2mortal(dstr);
 526                     (void)astore(ary, ++sp, dstr);
 527                 }
 528             }
 529             s = spat->spat_regexp->endp[0];
 530         }
 531     }
 532     if (realarray)
 533         iters = sp + 1;
 534     else
 535         iters = sp - arglast[0];
 536     if (iters > maxiters)
 537         fatal("Split loop");
 538     if (s < strend || origlimit) {      /* keep field after final delim? */
 539         dstr = Str_new(34,strend-s);
 540         str_nset(dstr,s,strend-s);
 541         if (!realarray)
 542             str_2mortal(dstr);
 543         (void)astore(ary, ++sp, dstr);
 544         iters++;
 545     }
 546     else {
 547 #ifndef I286x
 548         while (iters > 0 && ary->ary_array[sp]->str_cur == 0)
 549             iters--,sp--;
 550 #else
 551         char *zaps;
 552         int   zapb;
 553
 554         if (iters > 0) {
 555                 zaps = str_get(afetch(ary,sp,FALSE));
 556                 zapb = (int) *zaps;
 557         }
 558
 559         while (iters > 0 && (!zapb)) {
 560             iters--,sp--;
 561             if (iters > 0) {
 562                 zaps = str_get(afetch(ary,iters-1,FALSE));
 563                 zapb = (int) *zaps;
 564             }
 565         }
 566 #endif
 567     }
 568     if (realarray) {
 569         ary->ary_fill = sp;
 570         if (gimme == G_ARRAY) {
 571             sp++;
 572             astore(stack, arglast[0] + 1 + sp, Nullstr);
 573             Copy(ary->ary_array, stack->ary_array + arglast[0] + 1, sp, STR*);
 574             return arglast[0] + sp;
 575         }
 576     }
 577     else {
 578         if (gimme == G_ARRAY)
 579             return sp;
 580     }
 581     sp = arglast[0] + 1;
 582     str_numset(str,(double)iters);
 583     STABSET(str);
 584     st[sp] = str;
 585     return sp;
 586 }
 587
 588 int
 589 do_unpack(str,gimme,arglast)
 590 STR *str;
 591 int gimme;
 592 int *arglast;
 593 {
 594     STR **st = stack->ary_array;
 595     register int sp = arglast[0] + 1;
 596     register char *pat = str_get(st[sp++]);
 597     register char *s = str_get(st[sp]);
 598     char *strend = s + st[sp--]->str_cur;
 599     char *strbeg = s;
 600     register char *patend = pat + st[sp]->str_cur;
 601     int datumtype;
 602     register int len;
 603     register int bits;
 604
 605     /* These must not be in registers: */
 606     short ashort;
 607     int aint;
 608     long along;
 609 #ifdef QUAD
 610     quad aquad;
 611 #endif
 612     unsigned short aushort;
 613     unsigned int auint;
 614     unsigned long aulong;
 615 #ifdef QUAD
 616     unsigned quad auquad;
 617 #endif
 618     char *aptr;
 619     float afloat;
 620     double adouble;
 621     int checksum = 0;
 622     unsigned long culong;
 623     double cdouble;
 624
 625     if (gimme != G_ARRAY) {             /* arrange to do first one only */
 626         /*SUPPRESS 530*/
 627         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
 628         if (index("aAbBhH", *patend) || *pat == '%') {
 629             patend++;
 630             while (isDIGIT(*patend) || *patend == '*')
 631                 patend++;
 632         }
 633         else
 634             patend++;
 635     }
 636     sp--;
 637     while (pat < patend) {
 638       reparse:
 639         datumtype = *pat++;
 640         if (pat >= patend)
 641             len = 1;
 642         else if (*pat == '*') {
 643             len = strend - strbeg;      /* long enough */
 644             pat++;
 645         }
 646         else if (isDIGIT(*pat)) {
 647             len = *pat++ - '0';
 648             while (isDIGIT(*pat))
 649                 len = (len * 10) + (*pat++ - '0');
 650         }
 651         else
 652             len = (datumtype != '@');
 653         switch(datumtype) {
 654         default:
 655             break;
 656         case '%':
 657             if (len == 1 && pat[-1] != '1')
 658                 len = 16;
 659             checksum = len;
 660             culong = 0;
 661             cdouble = 0;
 662             if (pat < patend)
 663                 goto reparse;
 664             break;
 665         case '@':
 666             if (len > strend - strbeg)
 667                 fatal("@ outside of string");
 668             s = strbeg + len;
 669             break;
 670         case 'X':
 671             if (len > s - strbeg)
 672                 fatal("X outside of string");
 673             s -= len;
 674             break;
 675         case 'x':
 676             if (len > strend - s)
 677                 fatal("x outside of string");
 678             s += len;
 679             break;
 680         case 'A':
 681         case 'a':
 682             if (len > strend - s)
 683                 len = strend - s;
 684             if (checksum)
 685                 goto uchar_checksum;
 686             str = Str_new(35,len);
 687             str_nset(str,s,len);
 688             s += len;
 689             if (datumtype == 'A') {
 690                 aptr = s;       /* borrow register */
 691                 s = str->str_ptr + len - 1;
 692                 while (s >= str->str_ptr && (!*s || isSPACE(*s)))
 693                     s--;
 694                 *++s = '\0';
 695                 str->str_cur = s - str->str_ptr;
 696                 s = aptr;       /* unborrow register */
 697             }
 698             (void)astore(stack, ++sp, str_2mortal(str));
 699             break;
 700         case 'B':
 701         case 'b':
 702             if (pat[-1] == '*' || len > (strend - s) * 8)
 703                 len = (strend - s) * 8;
 704             str = Str_new(35, len + 1);
 705             str->str_cur = len;
 706             str->str_pok = 1;
 707             aptr = pat;                 /* borrow register */
 708             pat = str->str_ptr;
 709             if (datumtype == 'b') {
 710                 aint = len;
 711                 for (len = 0; len < aint; len++) {
 712                     if (len & 7)                /*SUPPRESS 595*/
 713                         bits >>= 1;
 714                     else
 715                         bits = *s++;
 716                     *pat++ = '0' + (bits & 1);
 717                 }
 718             }
 719             else {
 720                 aint = len;
 721                 for (len = 0; len < aint; len++) {
 722                     if (len & 7)
 723                         bits <<= 1;
 724                     else
 725                         bits = *s++;
 726                     *pat++ = '0' + ((bits & 128) != 0);
 727                 }
 728             }
 729             *pat = '\0';
 730             pat = aptr;                 /* unborrow register */
 731             (void)astore(stack, ++sp, str_2mortal(str));
 732             break;
 733         case 'H':
 734         case 'h':
 735             if (pat[-1] == '*' || len > (strend - s) * 2)
 736                 len = (strend - s) * 2;
 737             str = Str_new(35, len + 1);
 738             str->str_cur = len;
 739             str->str_pok = 1;
 740             aptr = pat;                 /* borrow register */
 741             pat = str->str_ptr;
 742             if (datumtype == 'h') {
 743                 aint = len;
 744                 for (len = 0; len < aint; len++) {
 745                     if (len & 1)
 746                         bits >>= 4;
 747                     else
 748                         bits = *s++;
 749                     *pat++ = hexdigit[bits & 15];
 750                 }
 751             }
 752             else {
 753                 aint = len;
 754                 for (len = 0; len < aint; len++) {
 755                     if (len & 1)
 756                         bits <<= 4;
 757                     else
 758                         bits = *s++;
 759                     *pat++ = hexdigit[(bits >> 4) & 15];
 760                 }
 761             }
 762             *pat = '\0';
 763             pat = aptr;                 /* unborrow register */
 764             (void)astore(stack, ++sp, str_2mortal(str));
 765             break;
 766         case 'c':
 767             if (len > strend - s)
 768                 len = strend - s;
 769             if (checksum) {
 770                 while (len-- > 0) {
 771                     aint = *s++;
 772                     if (aint >= 128)    /* fake up signed chars */
 773                         aint -= 256;
 774                     culong += aint;
 775                 }
 776             }
 777             else {
 778                 while (len-- > 0) {
 779                     aint = *s++;
 780                     if (aint >= 128)    /* fake up signed chars */
 781                         aint -= 256;
 782                     str = Str_new(36,0);
 783                     str_numset(str,(double)aint);
 784                     (void)astore(stack, ++sp, str_2mortal(str));
 785                 }
 786             }
 787             break;
 788         case 'C':
 789             if (len > strend - s)
 790                 len = strend - s;
 791             if (checksum) {
 792               uchar_checksum:
 793                 while (len-- > 0) {
 794                     auint = *s++ & 255;
 795                     culong += auint;
 796                 }
 797             }
 798             else {
 799                 while (len-- > 0) {
 800                     auint = *s++ & 255;
 801                     str = Str_new(37,0);
 802                     str_numset(str,(double)auint);
 803                     (void)astore(stack, ++sp, str_2mortal(str));
 804                 }
 805             }
 806             break;
 807         case 's':
 808             along = (strend - s) / sizeof(short);
 809             if (len > along)
 810                 len = along;
 811             if (checksum) {
 812                 while (len-- > 0) {
 813                     Copy(s,&ashort,1,short);
 814                     s += sizeof(short);
 815                     culong += ashort;
 816                 }
 817             }
 818             else {
 819                 while (len-- > 0) {
 820                     Copy(s,&ashort,1,short);
 821                     s += sizeof(short);
 822                     str = Str_new(38,0);
 823                     str_numset(str,(double)ashort);
 824                     (void)astore(stack, ++sp, str_2mortal(str));
 825                 }
 826             }
 827             break;
 828         case 'v':
 829         case 'n':
 830         case 'S':
 831             along = (strend - s) / sizeof(unsigned short);
 832             if (len > along)
 833                 len = along;
 834             if (checksum) {
 835                 while (len-- > 0) {
 836                     Copy(s,&aushort,1,unsigned short);
 837                     s += sizeof(unsigned short);
 838 #ifdef HAS_NTOHS
 839                     if (datumtype == 'n')
 840                         aushort = ntohs(aushort);
 841 #endif
 842 #ifdef HAS_VTOHS
 843                     if (datumtype == 'v')
 844                         aushort = vtohs(aushort);
 845 #endif
 846                     culong += aushort;
 847                 }
 848             }
 849             else {
 850                 while (len-- > 0) {
 851                     Copy(s,&aushort,1,unsigned short);
 852                     s += sizeof(unsigned short);
 853                     str = Str_new(39,0);
 854 #ifdef HAS_NTOHS
 855                     if (datumtype == 'n')
 856                         aushort = ntohs(aushort);
 857 #endif
 858 #ifdef HAS_VTOHS
 859                     if (datumtype == 'v')
 860                         aushort = vtohs(aushort);
 861 #endif
 862                     str_numset(str,(double)aushort);
 863                     (void)astore(stack, ++sp, str_2mortal(str));
 864                 }
 865             }
 866             break;
 867         case 'i':
 868             along = (strend - s) / sizeof(int);
 869             if (len > along)
 870                 len = along;
 871             if (checksum) {
 872                 while (len-- > 0) {
 873                     Copy(s,&aint,1,int);
 874                     s += sizeof(int);
 875                     if (checksum > 32)
 876                         cdouble += (double)aint;
 877                     else
 878                         culong += aint;
 879                 }
 880             }
 881             else {
 882                 while (len-- > 0) {
 883                     Copy(s,&aint,1,int);
 884                     s += sizeof(int);
 885                     str = Str_new(40,0);
 886                     str_numset(str,(double)aint);
 887                     (void)astore(stack, ++sp, str_2mortal(str));
 888                 }
 889             }
 890             break;
 891         case 'I':
 892             along = (strend - s) / sizeof(unsigned int);
 893             if (len > along)
 894                 len = along;
 895             if (checksum) {
 896                 while (len-- > 0) {
 897                     Copy(s,&auint,1,unsigned int);
 898                     s += sizeof(unsigned int);
 899                     if (checksum > 32)
 900                         cdouble += (double)auint;
 901                     else
 902                         culong += auint;
 903                 }
 904             }
 905             else {
 906                 while (len-- > 0) {
 907                     Copy(s,&auint,1,unsigned int);
 908                     s += sizeof(unsigned int);
 909                     str = Str_new(41,0);
 910                     str_numset(str,(double)auint);
 911                     (void)astore(stack, ++sp, str_2mortal(str));
 912                 }
 913             }
 914             break;
 915         case 'l':
 916             along = (strend - s) / sizeof(long);
 917             if (len > along)
 918                 len = along;
 919             if (checksum) {
 920                 while (len-- > 0) {
 921                     Copy(s,&along,1,long);
 922                     s += sizeof(long);
 923                     if (checksum > 32)
 924                         cdouble += (double)along;
 925                     else
 926                         culong += along;
 927                 }
 928             }
 929             else {
 930                 while (len-- > 0) {
 931                     Copy(s,&along,1,long);
 932                     s += sizeof(long);
 933                     str = Str_new(42,0);
 934                     str_numset(str,(double)along);
 935                     (void)astore(stack, ++sp, str_2mortal(str));
 936                 }
 937             }
 938             break;
 939         case 'V':
 940         case 'N':
 941         case 'L':
 942             along = (strend - s) / sizeof(unsigned long);
 943             if (len > along)
 944                 len = along;
 945             if (checksum) {
 946                 while (len-- > 0) {
 947                     Copy(s,&aulong,1,unsigned long);
 948                     s += sizeof(unsigned long);
 949 #ifdef HAS_NTOHL
 950                     if (datumtype == 'N')
 951                         aulong = ntohl(aulong);
 952 #endif
 953 #ifdef HAS_VTOHL
 954                     if (datumtype == 'V')
 955                         aulong = vtohl(aulong);
 956 #endif
 957                     if (checksum > 32)
 958                         cdouble += (double)aulong;
 959                     else
 960                         culong += aulong;
 961                 }
 962             }
 963             else {
 964                 while (len-- > 0) {
 965                     Copy(s,&aulong,1,unsigned long);
 966                     s += sizeof(unsigned long);
 967                     str = Str_new(43,0);
 968 #ifdef HAS_NTOHL
 969                     if (datumtype == 'N')
 970                         aulong = ntohl(aulong);
 971 #endif
 972 #ifdef HAS_VTOHL
 973                     if (datumtype == 'V')
 974                         aulong = vtohl(aulong);
 975 #endif
 976                     str_numset(str,(double)aulong);
 977                     (void)astore(stack, ++sp, str_2mortal(str));
 978                 }
 979             }
 980             break;
 981         case 'p':
 982             along = (strend - s) / sizeof(char*);
 983             if (len > along)
 984                 len = along;
 985             while (len-- > 0) {
 986                 if (sizeof(char*) > strend - s)
 987                     break;
 988                 else {
 989                     Copy(s,&aptr,1,char*);
 990                     s += sizeof(char*);
 991                 }
 992                 str = Str_new(44,0);
 993                 if (aptr)
 994                     str_set(str,aptr);
 995                 (void)astore(stack, ++sp, str_2mortal(str));
 996             }
 997             break;
 998 #ifdef QUAD
 999         case 'q':
1000             while (len-- > 0) {
1001                 if (s + sizeof(quad) > strend)
1002                     aquad = 0;
1003                 else {
1004                     Copy(s,&aquad,1,quad);
1005                     s += sizeof(quad);
1006                 }
1007                 str = Str_new(42,0);
1008                 str_numset(str,(double)aquad);
1009                 (void)astore(stack, ++sp, str_2mortal(str));
1010             }
1011             break;
1012         case 'Q':
1013             while (len-- > 0) {
1014                 if (s + sizeof(unsigned quad) > strend)
1015                     auquad = 0;
1016                 else {
1017                     Copy(s,&auquad,1,unsigned quad);
1018                     s += sizeof(unsigned quad);
1019                 }
1020                 str = Str_new(43,0);
1021                 str_numset(str,(double)auquad);
1022                 (void)astore(stack, ++sp, str_2mortal(str));
1023             }
1024             break;
1025 #endif
1026         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1027         case 'f':
1028         case 'F':
1029             along = (strend - s) / sizeof(float);
1030             if (len > along)
1031                 len = along;
1032             if (checksum) {
1033                 while (len-- > 0) {
1034                     Copy(s, &afloat,1, float);
1035                     s += sizeof(float);
1036                     cdouble += afloat;
1037                 }
1038             }
1039             else {
1040                 while (len-- > 0) {
1041                     Copy(s, &afloat,1, float);
1042                     s += sizeof(float);
1043                     str = Str_new(47, 0);
1044                     str_numset(str, (double)afloat);
1045                     (void)astore(stack, ++sp, str_2mortal(str));
1046                 }
1047             }
1048             break;
1049         case 'd':
1050         case 'D':
1051             along = (strend - s) / sizeof(double);
1052             if (len > along)
1053                 len = along;
1054             if (checksum) {
1055                 while (len-- > 0) {
1056                     Copy(s, &adouble,1, double);
1057                     s += sizeof(double);
1058                     cdouble += adouble;
1059                 }
1060             }
1061             else {
1062                 while (len-- > 0) {
1063                     Copy(s, &adouble,1, double);
1064                     s += sizeof(double);
1065                     str = Str_new(48, 0);
1066                     str_numset(str, (double)adouble);
1067                     (void)astore(stack, ++sp, str_2mortal(str));
1068                 }
1069             }
1070             break;
1071         case 'u':
1072             along = (strend - s) * 3 / 4;
1073             str = Str_new(42,along);
1074             while (s < strend && *s > ' ' && *s < 'a') {
1075                 int a,b,c,d;
1076                 char hunk[4];
1077
1078                 hunk[3] = '\0';
1079                 len = (*s++ - ' ') & 077;
1080                 while (len > 0) {
1081                     if (s < strend && *s >= ' ')
1082                         a = (*s++ - ' ') & 077;
1083                     else
1084                         a = 0;
1085                     if (s < strend && *s >= ' ')
1086                         b = (*s++ - ' ') & 077;
1087                     else
1088                         b = 0;
1089                     if (s < strend && *s >= ' ')
1090                         c = (*s++ - ' ') & 077;
1091                     else
1092                         c = 0;
1093                     if (s < strend && *s >= ' ')
1094                         d = (*s++ - ' ') & 077;
1095                     else
1096                         d = 0;
1097                     hunk[0] = a << 2 | b >> 4;
1098                     hunk[1] = b << 4 | c >> 2;
1099                     hunk[2] = c << 6 | d;
1100                     str_ncat(str,hunk, len > 3 ? 3 : len);
1101                     len -= 3;
1102                 }
1103                 if (*s == '\n')
1104                     s++;
1105                 else if (s[1] == '\n')          /* possible checksum byte */
1106                     s += 2;
1107             }
1108             (void)astore(stack, ++sp, str_2mortal(str));
1109             break;
1110         }
1111         if (checksum) {
1112             str = Str_new(42,0);
1113             if (index("fFdD", datumtype) ||
1114               (checksum > 32 && index("iIlLN", datumtype)) ) {
1115                 double modf();
1116                 double trouble;
1117
1118                 adouble = 1.0;
1119                 while (checksum >= 16) {
1120                     checksum -= 16;
1121                     adouble *= 65536.0;
1122                 }
1123                 while (checksum >= 4) {
1124                     checksum -= 4;
1125                     adouble *= 16.0;
1126                 }
1127                 while (checksum--)
1128                     adouble *= 2.0;
1129                 along = (1 << checksum) - 1;
1130                 while (cdouble < 0.0)
1131                     cdouble += adouble;
1132                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
1133                 str_numset(str,cdouble);
1134             }
1135             else {
1136                 if (checksum < 32) {
1137                     along = (1 << checksum) - 1;
1138                     culong &= (unsigned long)along;
1139                 }
1140                 str_numset(str,(double)culong);
1141             }
1142             (void)astore(stack, ++sp, str_2mortal(str));
1143             checksum = 0;
1144         }
1145     }
1146     return sp;
1147 }
1148
1149 int
1150 do_slice(stab,str,numarray,lval,gimme,arglast)
1151 STAB *stab;
1152 STR *str;
1153 int numarray;
1154 int lval;
1155 int gimme;
1156 int *arglast;
1157 {
1158     register STR **st = stack->ary_array;
1159     register int sp = arglast[1];
1160     register int max = arglast[2];
1161     register char *tmps;
1162     register int len;
1163     register int magic = 0;
1164     register ARRAY *ary;
1165     register HASH *hash;
1166     int oldarybase = arybase;
1167
1168     if (numarray) {
1169         if (numarray == 2) {            /* a slice of a LIST */
1170             ary = stack;
1171             ary->ary_fill = arglast[3];
1172             arybase -= max + 1;
1173             st[sp] = str;               /* make stack size available */
1174             str_numset(str,(double)(sp - 1));
1175         }
1176         else
1177             ary = stab_array(stab);     /* a slice of an array */
1178     }
1179     else {
1180         if (lval) {
1181             if (stab == envstab)
1182                 magic = 'E';
1183             else if (stab == sigstab)
1184                 magic = 'S';
1185 #ifdef SOME_DBM
1186             else if (stab_hash(stab)->tbl_dbm)
1187                 magic = 'D';
1188 #endif /* SOME_DBM */
1189         }
1190         hash = stab_hash(stab);         /* a slice of an associative array */
1191     }
1192
1193     if (gimme == G_ARRAY) {
1194         if (numarray) {
1195             while (sp < max) {
1196                 if (st[++sp]) {
1197                     st[sp-1] = afetch(ary,
1198                       ((int)str_gnum(st[sp])) - arybase, lval);
1199                 }
1200                 else
1201                     st[sp-1] = &str_undef;
1202             }
1203         }
1204         else {
1205             while (sp < max) {
1206                 if (st[++sp]) {
1207                     tmps = str_get(st[sp]);
1208                     len = st[sp]->str_cur;
1209                     st[sp-1] = hfetch(hash,tmps,len, lval);
1210                     if (magic)
1211                         str_magic(st[sp-1],stab,magic,tmps,len);
1212                 }
1213                 else
1214                     st[sp-1] = &str_undef;
1215             }
1216         }
1217         sp--;
1218     }
1219     else {
1220         if (sp == max)
1221             st[sp] = &str_undef;
1222         else if (numarray) {
1223             if (st[max])
1224                 st[sp] = afetch(ary,
1225                   ((int)str_gnum(st[max])) - arybase, lval);
1226             else
1227                 st[sp] = &str_undef;
1228         }
1229         else {
1230             if (st[max]) {
1231                 tmps = str_get(st[max]);
1232                 len = st[max]->str_cur;
1233                 st[sp] = hfetch(hash,tmps,len, lval);
1234                 if (magic)
1235                     str_magic(st[sp],stab,magic,tmps,len);
1236             }
1237             else
1238                 st[sp] = &str_undef;
1239         }
1240     }
1241     arybase = oldarybase;
1242     return sp;
1243 }
1244
1245 int
1246 do_splice(ary,gimme,arglast)
1247 register ARRAY *ary;
1248 int gimme;
1249 int *arglast;
1250 {
1251     register STR **st = stack->ary_array;
1252     register int sp = arglast[1];
1253     int max = arglast[2] + 1;
1254     register STR **src;
1255     register STR **dst;
1256     register int i;
1257     register int offset;
1258     register int length;
1259     int newlen;
1260     int after;
1261     int diff;
1262     STR **tmparyval;
1263
1264     if (++sp < max) {
1265         offset = (int)str_gnum(st[sp]);
1266         if (offset < 0)
1267             offset += ary->ary_fill + 1;
1268         else
1269             offset -= arybase;
1270         if (++sp < max) {
1271             length = (int)str_gnum(st[sp++]);
1272             if (length < 0)
1273                 length = 0;
1274         }
1275         else
1276             length = ary->ary_max + 1;          /* close enough to infinity */
1277     }
1278     else {
1279         offset = 0;
1280         length = ary->ary_max + 1;
1281     }
1282     if (offset < 0) {
1283         length += offset;
1284         offset = 0;
1285         if (length < 0)
1286             length = 0;
1287     }
1288     if (offset > ary->ary_fill + 1)
1289         offset = ary->ary_fill + 1;
1290     after = ary->ary_fill + 1 - (offset + length);
1291     if (after < 0) {                            /* not that much array */
1292         length += after;                        /* offset+length now in array */
1293         after = 0;
1294         if (!ary->ary_alloc) {
1295             afill(ary,0);
1296             afill(ary,-1);
1297         }
1298     }
1299
1300     /* At this point, sp .. max-1 is our new LIST */
1301
1302     newlen = max - sp;
1303     diff = newlen - length;
1304
1305     if (diff < 0) {                             /* shrinking the area */
1306         if (newlen) {
1307             New(451, tmparyval, newlen, STR*);  /* so remember insertion */
1308             Copy(st+sp, tmparyval, newlen, STR*);
1309         }
1310
1311         sp = arglast[0] + 1;
1312         if (gimme == G_ARRAY) {                 /* copy return vals to stack */
1313             if (sp + length >= stack->ary_max) {
1314                 astore(stack,sp + length, Nullstr);
1315                 st = stack->ary_array;
1316             }
1317             Copy(ary->ary_array+offset, st+sp, length, STR*);
1318             if (ary->ary_flags & ARF_REAL) {
1319                 for (i = length, dst = st+sp; i; i--)
1320                     str_2mortal(*dst++);        /* free them eventualy */
1321             }
1322             sp += length - 1;
1323         }
1324         else {
1325             st[sp] = ary->ary_array[offset+length-1];
1326             if (ary->ary_flags & ARF_REAL) {
1327                 str_2mortal(st[sp]);
1328                 for (i = length - 1, dst = &ary->ary_array[offset]; i > 0; i--)
1329                     str_free(*dst++);   /* free them now */
1330             }
1331         }
1332         ary->ary_fill += diff;
1333
1334         /* pull up or down? */
1335
1336         if (offset < after) {                   /* easier to pull up */
1337             if (offset) {                       /* esp. if nothing to pull */
1338                 src = &ary->ary_array[offset-1];
1339                 dst = src - diff;               /* diff is negative */
1340                 for (i = offset; i > 0; i--)    /* can't trust Copy */
1341                     *dst-- = *src--;
1342             }
1343             Zero(ary->ary_array, -diff, STR*);
1344             ary->ary_array -= diff;             /* diff is negative */
1345             ary->ary_max += diff;
1346         }
1347         else {
1348             if (after) {                        /* anything to pull down? */
1349                 src = ary->ary_array + offset + length;
1350                 dst = src + diff;               /* diff is negative */
1351                 Move(src, dst, after, STR*);
1352             }
1353             Zero(&ary->ary_array[ary->ary_fill+1], -diff, STR*);
1354                                                 /* avoid later double free */
1355         }
1356         if (newlen) {
1357             for (src = tmparyval, dst = ary->ary_array + offset;
1358               newlen; newlen--) {
1359                 *dst = Str_new(46,0);
1360                 str_sset(*dst++,*src++);
1361             }
1362             Safefree(tmparyval);
1363         }
1364     }
1365     else {                                      /* no, expanding (or same) */
1366         if (length) {
1367             New(452, tmparyval, length, STR*);  /* so remember deletion */
1368             Copy(ary->ary_array+offset, tmparyval, length, STR*);
1369         }
1370
1371         if (diff > 0) {                         /* expanding */
1372
1373             /* push up or down? */
1374
1375             if (offset < after && diff <= ary->ary_array - ary->ary_alloc) {
1376                 if (offset) {
1377                     src = ary->ary_array;
1378                     dst = src - diff;
1379                     Move(src, dst, offset, STR*);
1380                 }
1381                 ary->ary_array -= diff;         /* diff is positive */
1382                 ary->ary_max += diff;
1383                 ary->ary_fill += diff;
1384             }
1385             else {
1386                 if (ary->ary_fill + diff >= ary->ary_max)       /* oh, well */
1387                     astore(ary, ary->ary_fill + diff, Nullstr);
1388                 else
1389                     ary->ary_fill += diff;
1390                 dst = ary->ary_array + ary->ary_fill;
1391                 for (i = diff; i > 0; i--) {
1392                     if (*dst)                   /* str was hanging around */
1393                         str_free(*dst);         /*  after $#foo */
1394                     dst--;
1395                 }
1396                 if (after) {
1397                     dst = ary->ary_array + ary->ary_fill;
1398                     src = dst - diff;
1399                     for (i = after; i; i--) {
1400                         *dst-- = *src--;
1401                     }
1402                 }
1403             }
1404         }
1405
1406         for (src = st+sp, dst = ary->ary_array + offset; newlen; newlen--) {
1407             *dst = Str_new(46,0);
1408             str_sset(*dst++,*src++);
1409         }
1410         sp = arglast[0] + 1;
1411         if (gimme == G_ARRAY) {                 /* copy return vals to stack */
1412             if (length) {
1413                 Copy(tmparyval, st+sp, length, STR*);
1414                 if (ary->ary_flags & ARF_REAL) {
1415                     for (i = length, dst = st+sp; i; i--)
1416                         str_2mortal(*dst++);    /* free them eventualy */
1417                 }
1418                 Safefree(tmparyval);
1419             }
1420             sp += length - 1;
1421         }
1422         else if (length--) {
1423             st[sp] = tmparyval[length];
1424             if (ary->ary_flags & ARF_REAL) {
1425                 str_2mortal(st[sp]);
1426                 while (length-- > 0)
1427                     str_free(tmparyval[length]);
1428             }
1429             Safefree(tmparyval);
1430         }
1431         else
1432             st[sp] = &str_undef;
1433     }
1434     return sp;
1435 }
1436
1437 int
1438 do_grep(arg,str,gimme,arglast)
1439 register ARG *arg;
1440 STR *str;
1441 int gimme;
1442 int *arglast;
1443 {
1444     STR **st = stack->ary_array;
1445     register int dst = arglast[1];
1446     register int src = dst + 1;
1447     register int sp = arglast[2];
1448     register int i = sp - arglast[1];
1449     int oldsave = savestack->ary_fill;
1450     SPAT *oldspat = curspat;
1451     int oldtmps_base = tmps_base;
1452
1453     savesptr(&stab_val(defstab));
1454     tmps_base = tmps_max;
1455     if ((arg[1].arg_type & A_MASK) != A_EXPR) {
1456         arg[1].arg_type &= A_MASK;
1457         dehoist(arg,1);
1458         arg[1].arg_type |= A_DONT;
1459     }
1460     arg = arg[1].arg_ptr.arg_arg;
1461     while (i-- > 0) {
1462         if (st[src]) {
1463             st[src]->str_pok &= ~SP_TEMP;
1464             stab_val(defstab) = st[src];
1465         }
1466         else
1467             stab_val(defstab) = str_mortal(&str_undef);
1468         (void)eval(arg,G_SCALAR,sp);
1469         st = stack->ary_array;
1470         if (str_true(st[sp+1]))
1471             st[dst++] = st[src];
1472         src++;
1473         curspat = oldspat;
1474     }
1475     restorelist(oldsave);
1476     tmps_base = oldtmps_base;
1477     if (gimme != G_ARRAY) {
1478         str_numset(str,(double)(dst - arglast[1]));
1479         STABSET(str);
1480         st[arglast[0]+1] = str;
1481         return arglast[0]+1;
1482     }
1483     return arglast[0] + (dst - arglast[1]);
1484 }
1485
1486 int
1487 do_reverse(arglast)
1488 int *arglast;
1489 {
1490     STR **st = stack->ary_array;
1491     register STR **up = &st[arglast[1]];
1492     register STR **down = &st[arglast[2]];
1493     register int i = arglast[2] - arglast[1];
1494
1495     while (i-- > 0) {
1496         *up++ = *down;
1497         if (i-- > 0)
1498             *down-- = *up;
1499     }
1500     i = arglast[2] - arglast[1];
1501     Move(down+1,up,i/2,STR*);
1502     return arglast[2] - 1;
1503 }
1504
1505 int
1506 do_sreverse(str,arglast)
1507 STR *str;
1508 int *arglast;
1509 {
1510     STR **st = stack->ary_array;
1511     register char *up;
1512     register char *down;
1513     register int tmp;
1514
1515     str_sset(str,st[arglast[2]]);
1516     up = str_get(str);
1517     if (str->str_cur > 1) {
1518         down = str->str_ptr + str->str_cur - 1;
1519         while (down > up) {
1520             tmp = *up;
1521             *up++ = *down;
1522             *down-- = tmp;
1523         }
1524     }
1525     STABSET(str);
1526     st[arglast[0]+1] = str;
1527     return arglast[0]+1;
1528 }
1529
1530 static CMD *sortcmd;
1531 static HASH *sortstash = Null(HASH*);
1532 static STAB *firststab = Nullstab;
1533 static STAB *secondstab = Nullstab;
1534
1535 int
1536 do_sort(str,arg,gimme,arglast)
1537 STR *str;
1538 ARG *arg;
1539 int gimme;
1540 int *arglast;
1541 {
1542     register STR **st = stack->ary_array;
1543     int sp = arglast[1];
1544     register STR **up;
1545     register int max = arglast[2] - sp;
1546     register int i;
1547     int sortcmp();
1548     int sortsub();
1549     STR *oldfirst;
1550     STR *oldsecond;
1551     ARRAY *oldstack;
1552     HASH *stash;
1553     STR *sortsubvar;
1554     static ARRAY *sortstack = Null(ARRAY*);
1555
1556     if (gimme != G_ARRAY) {
1557         str_sset(str,&str_undef);
1558         STABSET(str);
1559         st[sp] = str;
1560         return sp;
1561     }
1562     up = &st[sp];
1563     sortsubvar = *up;
1564     st += sp;           /* temporarily make st point to args */
1565     for (i = 1; i <= max; i++) {
1566         /*SUPPRESS 560*/
1567         if (*up = st[i]) {
1568             if (!(*up)->str_pok)
1569                 (void)str_2ptr(*up);
1570             else
1571                 (*up)->str_pok &= ~SP_TEMP;
1572             up++;
1573         }
1574     }
1575     st -= sp;
1576     max = up - &st[sp];
1577     sp--;
1578     if (max > 1) {
1579         STAB *stab;
1580
1581         if (arg[1].arg_type == (A_CMD|A_DONT)) {
1582             sortcmd = arg[1].arg_ptr.arg_cmd;
1583             stash = curcmd->c_stash;
1584         }
1585         else {
1586             if ((arg[1].arg_type & A_MASK) == A_WORD)
1587                 stab = arg[1].arg_ptr.arg_stab;
1588             else
1589                 stab = stabent(str_get(sortsubvar),TRUE);
1590
1591             if (stab) {
1592                 if (!stab_sub(stab) || !(sortcmd = stab_sub(stab)->cmd))
1593                     fatal("Undefined subroutine \"%s\" in sort",
1594                         stab_ename(stab));
1595                 stash = stab_estash(stab);
1596             }
1597             else
1598                 sortcmd = Nullcmd;
1599         }
1600
1601         if (sortcmd) {
1602             int oldtmps_base = tmps_base;
1603
1604             if (!sortstack) {
1605                 sortstack = anew(Nullstab);
1606                 astore(sortstack, 0, Nullstr);
1607                 aclear(sortstack);
1608                 sortstack->ary_flags = 0;
1609             }
1610             oldstack = stack;
1611             stack = sortstack;
1612             tmps_base = tmps_max;
1613             if (sortstash != stash) {
1614                 firststab = stabent("a",TRUE);
1615                 secondstab = stabent("b",TRUE);
1616                 sortstash = stash;
1617             }
1618             oldfirst = stab_val(firststab);
1619             oldsecond = stab_val(secondstab);
1620 #ifndef lint
1621             qsort((char*)(st+sp+1),max,sizeof(STR*),sortsub);
1622 #else
1623             qsort(Nullch,max,sizeof(STR*),sortsub);
1624 #endif
1625             stab_val(firststab) = oldfirst;
1626             stab_val(secondstab) = oldsecond;
1627             tmps_base = oldtmps_base;
1628             stack = oldstack;
1629         }
1630 #ifndef lint
1631         else
1632             qsort((char*)(st+sp+1),max,sizeof(STR*),sortcmp);
1633 #endif
1634     }
1635     return sp+max;
1636 }
1637
1638 static int
1639 sortsub(str1,str2)
1640 STR **str1;
1641 STR **str2;
1642 {
1643     stab_val(firststab) = *str1;
1644     stab_val(secondstab) = *str2;
1645     cmd_exec(sortcmd,G_SCALAR,-1);
1646     return (int)str_gnum(*stack->ary_array);
1647 }
1648
1649 static int
1650 sortcmp(strp1,strp2)
1651 STR **strp1;
1652 STR **strp2;
1653 {
1654     register STR *str1 = *strp1;
1655     register STR *str2 = *strp2;
1656     int retval;
1657
1658     if (str1->str_cur < str2->str_cur) {
1659         /*SUPPRESS 560*/
1660         if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur))
1661             return retval;
1662         else
1663             return -1;
1664     }
1665     /*SUPPRESS 560*/
1666     else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur))
1667         return retval;
1668     else if (str1->str_cur == str2->str_cur)
1669         return 0;
1670     else
1671         return 1;
1672 }
1673
1674 int
1675 do_range(gimme,arglast)
1676 int gimme;
1677 int *arglast;
1678 {
1679     STR **st = stack->ary_array;
1680     register int sp = arglast[0];
1681     register int i;
1682     register ARRAY *ary = stack;
1683     register STR *str;
1684     int max;
1685
1686     if (gimme != G_ARRAY)
1687         fatal("panic: do_range");
1688
1689     if (st[sp+1]->str_nok || !st[sp+1]->str_pok ||
1690       (looks_like_number(st[sp+1]) && *st[sp+1]->str_ptr != '0') ) {
1691         i = (int)str_gnum(st[sp+1]);
1692         max = (int)str_gnum(st[sp+2]);
1693         if (max > i)
1694             (void)astore(ary, sp + max - i + 1, Nullstr);
1695         while (i <= max) {
1696             (void)astore(ary, ++sp, str = str_mortal(&str_no));
1697             str_numset(str,(double)i++);
1698         }
1699     }
1700     else {
1701         STR *final = str_mortal(st[sp+2]);
1702         char *tmps = str_get(final);
1703
1704         str = str_mortal(st[sp+1]);
1705         while (!str->str_nok && str->str_cur <= final->str_cur &&
1706             strNE(str->str_ptr,tmps) ) {
1707             (void)astore(ary, ++sp, str);
1708             str = str_2mortal(str_smake(str));
1709             str_inc(str);
1710         }
1711         if (strEQ(str->str_ptr,tmps))
1712             (void)astore(ary, ++sp, str);
1713     }
1714     return sp;
1715 }
1716
1717 int
1718 do_repeatary(arglast)
1719 int *arglast;
1720 {
1721     STR **st = stack->ary_array;
1722     register int sp = arglast[0];
1723     register int items = arglast[1] - sp;
1724     register int count = (int) str_gnum(st[arglast[2]]);
1725     register int i;
1726     int max;
1727
1728     max = items * count;
1729     if (max > 0 && sp + max > stack->ary_max) {
1730         astore(stack, sp + max, Nullstr);
1731         st = stack->ary_array;
1732     }
1733     if (count > 1) {
1734         for (i = arglast[1]; i > sp; i--)
1735             st[i]->str_pok &= ~SP_TEMP;
1736         repeatcpy((char*)&st[arglast[1]+1], (char*)&st[sp+1],
1737             items * sizeof(STR*), count);
1738     }
1739     sp += max;
1740
1741     return sp;
1742 }
1743
1744 int
1745 do_caller(arg,maxarg,gimme,arglast)
1746 ARG *arg;
1747 int maxarg;
1748 int gimme;
1749 int *arglast;
1750 {
1751     STR **st = stack->ary_array;
1752     register int sp = arglast[0];
1753     register CSV *csv = curcsv;
1754     STR *str;
1755     int count = 0;
1756
1757     if (!csv)
1758         fatal("There is no caller");
1759     if (maxarg)
1760         count = (int) str_gnum(st[sp+1]);
1761     for (;;) {
1762         if (!csv)
1763             return sp;
1764         if (DBsub && csv->curcsv && csv->curcsv->sub == stab_sub(DBsub))
1765             count++;
1766         if (!count--)
1767             break;
1768         csv = csv->curcsv;
1769     }
1770     if (gimme != G_ARRAY) {
1771         STR *str = arg->arg_ptr.arg_str;
1772         str_set(str,csv->curcmd->c_stash->tbl_name);
1773         STABSET(str);
1774         st[++sp] = str;
1775         return sp;
1776     }
1777
1778 #ifndef lint
1779     (void)astore(stack,++sp,
1780       str_2mortal(str_make(csv->curcmd->c_stash->tbl_name,0)) );
1781     (void)astore(stack,++sp,
1782       str_2mortal(str_make(stab_val(csv->curcmd->c_filestab)->str_ptr,0)) );
1783     (void)astore(stack,++sp,
1784       str_2mortal(str_nmake((double)csv->curcmd->c_line)) );
1785     if (!maxarg)
1786         return sp;
1787     str = Str_new(49,0);
1788     stab_efullname(str, csv->stab);
1789     (void)astore(stack,++sp, str_2mortal(str));
1790     (void)astore(stack,++sp,
1791       str_2mortal(str_nmake((double)csv->hasargs)) );
1792     (void)astore(stack,++sp,
1793       str_2mortal(str_nmake((double)csv->wantarray)) );
1794     if (csv->hasargs) {
1795         ARRAY *ary = csv->argarray;
1796
1797         if (!dbargs)
1798             dbargs = stab_xarray(aadd(stabent("DB'args", TRUE)));
1799         if (dbargs->ary_max < ary->ary_fill)
1800             astore(dbargs,ary->ary_fill,Nullstr);
1801         Copy(ary->ary_array, dbargs->ary_array, ary->ary_fill+1, STR*);
1802         dbargs->ary_fill = ary->ary_fill;
1803     }
1804 #else
1805     (void)astore(stack,++sp,
1806       str_2mortal(str_make("",0)));
1807 #endif
1808     return sp;
1809 }
1810
1811 int
1812 do_tms(str,gimme,arglast)
1813 STR *str;
1814 int gimme;
1815 int *arglast;
1816 {
1817 #ifdef MSDOS
1818     return -1;
1819 #else
1820     STR **st = stack->ary_array;
1821     register int sp = arglast[0];
1822
1823     if (gimme != G_ARRAY) {
1824         str_sset(str,&str_undef);
1825         STABSET(str);
1826         st[++sp] = str;
1827         return sp;
1828     }
1829     (void)times(&timesbuf);
1830
1831 #ifndef HZ
1832 #define HZ 60
1833 #endif
1834
1835 #ifndef lint
1836     (void)astore(stack,++sp,
1837       str_2mortal(str_nmake(((double)timesbuf.tms_utime)/HZ)));
1838     (void)astore(stack,++sp,
1839       str_2mortal(str_nmake(((double)timesbuf.tms_stime)/HZ)));
1840     (void)astore(stack,++sp,
1841       str_2mortal(str_nmake(((double)timesbuf.tms_cutime)/HZ)));
1842     (void)astore(stack,++sp,
1843       str_2mortal(str_nmake(((double)timesbuf.tms_cstime)/HZ)));
1844 #else
1845     (void)astore(stack,++sp,
1846       str_2mortal(str_nmake(0.0)));
1847 #endif
1848     return sp;
1849 #endif
1850 }
1851
1852 int
1853 do_time(str,tmbuf,gimme,arglast)
1854 STR *str;
1855 struct tm *tmbuf;
1856 int gimme;
1857 int *arglast;
1858 {
1859     register ARRAY *ary = stack;
1860     STR **st = ary->ary_array;
1861     register int sp = arglast[0];
1862
1863     if (!tmbuf || gimme != G_ARRAY) {
1864         str_sset(str,&str_undef);
1865         STABSET(str);
1866         st[++sp] = str;
1867         return sp;
1868     }
1869     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_sec)));
1870     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_min)));
1871     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_hour)));
1872     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mday)));
1873     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mon)));
1874     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_year)));
1875     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_wday)));
1876     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_yday)));
1877     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_isdst)));
1878     return sp;
1879 }
1880
1881 int
1882 do_kv(str,hash,kv,gimme,arglast)
1883 STR *str;
1884 HASH *hash;
1885 int kv;
1886 int gimme;
1887 int *arglast;
1888 {
1889     register ARRAY *ary = stack;
1890     STR **st = ary->ary_array;
1891     register int sp = arglast[0];
1892     int i;
1893     register HENT *entry;
1894     char *tmps;
1895     STR *tmpstr;
1896     int dokeys = (kv == O_KEYS || kv == O_HASH);
1897     int dovalues = (kv == O_VALUES || kv == O_HASH);
1898
1899     if (gimme != G_ARRAY) {
1900         i = 0;
1901         (void)hiterinit(hash);
1902         /*SUPPRESS 560*/
1903         while (entry = hiternext(hash)) {
1904             i++;
1905         }
1906         str_numset(str,(double)i);
1907         STABSET(str);
1908         st[++sp] = str;
1909         return sp;
1910     }
1911     (void)hiterinit(hash);
1912     /*SUPPRESS 560*/
1913     while (entry = hiternext(hash)) {
1914         if (dokeys) {
1915             tmps = hiterkey(entry,&i);
1916             if (!i)
1917                 tmps = "";
1918             (void)astore(ary,++sp,str_2mortal(str_make(tmps,i)));
1919         }
1920         if (dovalues) {
1921             tmpstr = Str_new(45,0);
1922 #ifdef DEBUGGING
1923             if (debug & 8192) {
1924                 sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
1925                     hash->tbl_max+1,entry->hent_hash & hash->tbl_max);
1926                 str_set(tmpstr,buf);
1927             }
1928             else
1929 #endif
1930             str_sset(tmpstr,hiterval(hash,entry));
1931             (void)astore(ary,++sp,str_2mortal(tmpstr));
1932         }
1933     }
1934     return sp;
1935 }
1936
1937 int
1938 do_each(str,hash,gimme,arglast)
1939 STR *str;
1940 HASH *hash;
1941 int gimme;
1942 int *arglast;
1943 {
1944     STR **st = stack->ary_array;
1945     register int sp = arglast[0];
1946     static STR *mystrk = Nullstr;
1947     HENT *entry = hiternext(hash);
1948     int i;
1949     char *tmps;
1950
1951     if (mystrk) {
1952         str_free(mystrk);
1953         mystrk = Nullstr;
1954     }
1955
1956     if (entry) {
1957         if (gimme == G_ARRAY) {
1958             tmps = hiterkey(entry, &i);
1959             if (!i)
1960                 tmps = "";
1961             st[++sp] = mystrk = str_make(tmps,i);
1962         }
1963         st[++sp] = str;
1964         str_sset(str,hiterval(hash,entry));
1965         STABSET(str);
1966         return sp;
1967     }
1968     else
1969         return sp;
1970 }