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