dolist.c

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