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