dolist.c

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