home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / perl / Source / C / Dolist < prev    next >
Encoding:
Text File  |  1991-02-09  |  41.4 KB  |  1,771 lines

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