dolist.c

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