home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / windows / c / xlisp21w / sources / xlseq.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-08  |  46.1 KB  |  1,759 lines
  1. /* xlseq.c - xlisp sequence functions */
  2. /*  Written by Thomas Almy, based on code:
  3.     Copyright (c) 1985, by David Michael Betz
  4.     All Rights Reserved
  5.     Permission is granted for unrestricted non-commercial use   */
  6.  
  7.  
  8. #include "xlisp.h"
  9.  
  10. /* external variables */
  11. extern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
  12. extern LVAL true;
  13.  
  14. /* this is part of the COMMON LISP extension: */
  15. /* (elt seq index)  -- generic sequence reference function */
  16. /* (map type fcn seq1 [seq2 ...]) -- generic sequence mapping function */
  17. /*   type is one of cons, array, string, or nil */
  18. /* (some fcn seq1 [seq2 ...]) -- apply fcn until non-nil */
  19. /*    also every notany and notevery */
  20. /* (concatenate type seq1 [seq2 ...]) -- sequence concatenation function */
  21. /*    type is one of cons, array, or string. */
  22. /* (position-if pred seq) -- returns position of first match */
  23. /* (search seq1 seq1 &key :test :test-not :start1 :end1 :start2 :end2) --
  24.     generic sequence searching function. */
  25. /* subseq reverse remove remove-if remove-if-not delete delete-if 
  26.    delete-if-not -- rewritten to allow all sequence types */
  27. /* find-if count-if -- previous Common Lisp extension, rewritten to allow
  28.    all sequence types */
  29. /* the keyword arguments :start and :end are now valid for the remove, delete,
  30.    find position and count functions */
  31. /* the keyword argument :key is also valid where appropriate */
  32.  
  33. /* The author, Tom Almy, appologizes for using "goto" several places in
  34.    this code. */
  35.  
  36. #ifdef ANSI
  37. static unsigned XNEAR getlength(LVAL seq)
  38. #else
  39. LOCAL unsigned getlength(seq)
  40. LVAL seq;
  41. #endif
  42. {
  43.     unsigned len;
  44.     
  45.     if (null(seq)) return 0;
  46.     
  47.     switch (ntype(seq)) {
  48.         case STRING: 
  49.             return (unsigned)(getslength(seq));
  50.         case VECTOR: 
  51.             return (unsigned)(getsize(seq));
  52.         case CONS: 
  53.             len = 0;
  54.             while (consp(seq)) {
  55.                 len++;
  56.                 if (len > MAXSLEN) xltoolong();
  57.                 seq = cdr(seq);
  58.             }
  59.             return len;
  60.         default: 
  61.             xlbadtype(seq);
  62.             return (0); /* ha ha */
  63.         }
  64. }
  65.  
  66.  
  67. #ifdef ANSI
  68. static void XNEAR getseqbounds(unsigned *start, unsigned *end,
  69.                     unsigned length, LVAL startkey, LVAL endkey)
  70. #else
  71. LOCAL VOID getseqbounds(start,end,length,startkey,endkey)
  72. unsigned *start, *end, length;
  73. LVAL startkey, endkey;
  74. #endif
  75. {
  76.     LVAL arg;
  77.     FIXTYPE temp;
  78.  
  79.     if (xlgkfixnum(startkey,&arg)) {
  80.         temp = getfixnum(arg);
  81.         if (temp < 0 || temp > length ) goto rangeError;
  82.         *start = (unsigned)temp;
  83.     }
  84.     else *start = 0;
  85.     
  86.     if (xlgetkeyarg(endkey, &arg) && !null(arg)) {
  87.         if (!fixp(arg)) xlbadtype(arg);
  88.         temp = getfixnum(arg);
  89.         if (temp < *start  || temp > length) goto rangeError;
  90.         *end = (unsigned)temp;  
  91.     }
  92.     else *end = length;
  93.     
  94.     return;
  95.     /* else there is a range error */
  96.     
  97. rangeError:
  98.     xlerror("range error",arg);
  99. }
  100.         
  101.  
  102. /* xelt - sequence reference function */
  103. LVAL xelt()
  104. {
  105.     LVAL seq,index;
  106.     FIXTYPE i;
  107.     
  108.     /* get the sequence and the index */
  109.  
  110.     seq = xlgetarg();
  111.  
  112.     index = xlgafixnum(); i = getfixnum(index); 
  113.     if (i < 0) goto badindex;
  114.     
  115.     xllastarg();
  116.  
  117.     if (listp(seq)) { /* do like nth, but check for in range */
  118.         /* find the ith element */
  119.         while (consp(seq)) {
  120.             if (i-- == 0) return (car(seq));
  121.             seq = cdr(seq);
  122.         }
  123.         goto badindex;  /* end of list reached first */
  124.     }
  125.         
  126.  
  127.     if (ntype(seq) == STRING) { 
  128.         if (i >= getslength(seq)) goto badindex;
  129.         return (cvchar(getstringch(seq,(int)i)));
  130.     }
  131.     
  132.     if (ntype(seq)!=VECTOR) xlbadtype(seq); /* type must be array */
  133.  
  134.     /* range check the index */
  135.     if (i >= getsize(seq)) goto badindex;
  136.  
  137.     /* return the array element */
  138.     return (getelement(seq,(int)i));
  139.     
  140. badindex:
  141.     xlerror("index out of bounds",index);
  142.     return (NIL);   /* eliminate warnings */
  143. }
  144.  
  145. #ifdef MAPFCNS
  146. /* xmap -- map function */
  147.  
  148. LVAL xmap()
  149. {
  150.     FRAMEP newfp;
  151.     LVAL fun, lists, val, last, x, y;
  152.     unsigned len,temp, i;
  153.     int argc, typ;
  154.     
  155.     /* protect some pointers */
  156.     xlstkcheck(3);
  157.     xlsave(fun);
  158.     xlsave(lists);
  159.     xlsave(val);
  160.  
  161.     /* get the type of resultant */
  162.     if (null((last = xlgetarg()))) {    /* nothing is returned */
  163.         typ = 0;
  164.     }
  165.     else if ((typ = xlcvttype(last)) != CONS && 
  166.                 typ != STRING && typ != VECTOR) {
  167.         xlerror("invalid result type", last);
  168.     }
  169.     
  170.     /* get the function to apply and argument sequences */
  171.     fun = xlgetarg();
  172.     val = NIL;
  173.     lists = xlgetarg();
  174.     len = getlength(lists);
  175.     argc = 1;
  176.  
  177.     /* build a list of argument lists */
  178.     for (lists = last = consa(lists); moreargs(); last = cdr(last)) {
  179.         val = xlgetarg();
  180.         if ((temp = getlength(val)) < len) len = temp;
  181.         argc++;
  182.         rplacd(last,(cons(val,NIL)));
  183.     }
  184.     
  185.     /* initialize the result list */
  186.     switch (typ) {
  187.         case VECTOR: 
  188.             val = newvector(len); 
  189.             break;
  190.         case STRING: 
  191.             val = newstring(len); 
  192.             val->n_string[len] = 0;
  193.             break;
  194.         default:    
  195.             val = NIL; 
  196.             break;
  197.     }
  198.     
  199.     
  200.     /* loop through each of the argument lists */
  201.     for (i=0;i<len;i++) {
  202.  
  203.         /* build an argument list from the sublists */
  204.         newfp = xlsp;
  205.         pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  206.         pusharg(fun);
  207.         pusharg(cvfixnum((FIXTYPE)argc));
  208.         for (x = lists; !null(x) ; x = cdr(x)) {
  209.             y = car(x);
  210.             switch (ntype(y)) {
  211.                 case CONS: 
  212.                     pusharg(car(y));
  213.                     rplaca(x,cdr(y));
  214.                     break;
  215.                 case VECTOR:
  216.                     pusharg(getelement(y,i));
  217.                     break;
  218.                 case STRING:
  219.                     pusharg(cvchar(getstringch(y,i)));
  220.                     break;
  221.             }
  222.         }
  223.  
  224.         /* apply the function to the arguments */
  225.         xlfp = newfp;
  226.         x = xlapply(argc);
  227.         
  228.         switch (typ) {
  229.             case CONS:
  230.                 y = consa(x);
  231.                 if (!null(val)) rplacd(last,y);
  232.                 else val = y;
  233.                 last = y;
  234.                 break;
  235.             case VECTOR:
  236.                 setelement(val,i,x);
  237.                 break;
  238.             case STRING:
  239.                 if (!charp(x)) 
  240.                     xlerror("map function returned non-character",x);
  241.                 val->n_string[i] = getchcode(x);
  242.                 break;
  243.         }
  244.             
  245.     }
  246.  
  247.     /* restore the stack */
  248.     xlpopn(3);
  249.  
  250.     /* return the last test expression value */
  251.     return (val);
  252.     }
  253.  
  254. /* every, some, notany, notevery */
  255.  
  256. #define EVERY 0
  257. #define SOME 1
  258. #define NOTEVERY 2
  259. #define NOTANY 3
  260.  
  261. #ifdef ANSI
  262. static LVAL XNEAR xlmapwhile(int cond)
  263. #else
  264. LOCAL LVAL xlmapwhile(cond)
  265. int cond;
  266. #endif
  267. {
  268.     int exitcond;
  269.     FRAMEP newfp;
  270.     LVAL fun, lists, val, last, x, y;
  271.     unsigned len,temp,i;
  272.     int argc;
  273.     
  274.     /* protect some pointers */
  275.     xlstkcheck(2);
  276.     xlsave(fun);
  277.     xlsave(lists);
  278.  
  279.     /* get the function to apply and argument sequences */
  280.     fun = xlgetarg();
  281.     lists = xlgetarg();
  282.     len = getlength(lists);
  283.     argc = 1;
  284.  
  285.     /* build a list of argument lists */
  286.     for (lists = last = consa(lists); moreargs(); last = cdr(last)) {
  287.         val = xlgetarg();
  288.         if ((temp = getlength(val)) < len) len = temp;
  289.         argc++;
  290.         rplacd(last,(cons(val,NIL)));
  291.     }
  292.     
  293.     switch (cond) {
  294.         case SOME:
  295.         case NOTANY:
  296.             exitcond = TRUE;
  297.             val = NIL;
  298.             break;
  299.         case EVERY:
  300.         case NOTEVERY:
  301.             exitcond = FALSE;
  302.             val = true;
  303.             break;
  304.     }
  305.  
  306.  
  307.     /* loop through each of the argument lists */
  308.     for (i=0;i<len;i++) {
  309.  
  310.         /* build an argument list from the sublists */
  311.         newfp = xlsp;
  312.         pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  313.         pusharg(fun);
  314.         pusharg(cvfixnum((FIXTYPE)argc));
  315.         for (x = lists; !null(x); x = cdr(x)) {
  316.             y = car(x);
  317.             switch (ntype(y)) {
  318.                 case CONS: 
  319.                     pusharg(car(y));
  320.                     rplaca(x,cdr(y));
  321.                     break;
  322.                 case VECTOR:
  323.                     pusharg(getelement(y,i));
  324.                     break;
  325.                 case STRING:
  326.                     pusharg(cvchar(getstringch(y,i)));
  327.                     break;
  328.             }
  329.         }
  330.  
  331.         /* apply the function to the arguments */
  332.         xlfp = newfp;
  333.         val = xlapply(argc);
  334.         if (null(val) ^ exitcond) break;
  335.     }
  336.  
  337.     if ((cond == NOTANY) | (cond == NOTEVERY))
  338.         val = (null(val) ? true : NIL);
  339.     
  340.  
  341.     /* restore the stack */
  342.     xlpopn(2);
  343.  
  344.     /* return the last test expression value */
  345.     return (val);
  346.     }
  347.  
  348.  
  349. LVAL xevery()
  350. {
  351.     return xlmapwhile(EVERY);
  352. }
  353.  
  354. LVAL xsome()
  355. {
  356.     return xlmapwhile(SOME);
  357. }
  358.  
  359. LVAL xnotany()
  360. {
  361.     return xlmapwhile(NOTANY);
  362. }
  363.  
  364. LVAL xnotevery()
  365. {
  366.     return xlmapwhile(NOTEVERY);
  367. }
  368. #endif
  369.  
  370. /* xconcatenate - concatenate a bunch of sequences */
  371. /* replaces (and extends) strcat, now a macro */
  372. LOCAL unsigned XNEAR calclength(VOIDP)
  373. {
  374.     LVAL tmp;
  375.     FRAMEP saveargv;
  376.     int saveargc;
  377.     long len;
  378.  
  379.     /* save the argument list */
  380.     saveargv = xlargv;
  381.     saveargc = xlargc;
  382.  
  383.     /* find the length of the new string or vector */
  384.     for (len = 0; moreargs(); ) {
  385.         tmp = xlgetarg();
  386.         len += getlength(tmp);
  387.  
  388.         if (len>MAXSLEN) xltoolong();  /*check for overflow*/
  389.     }
  390.  
  391.     /* restore the argument list */
  392.     xlargv = saveargv;
  393.     xlargc = saveargc;
  394.  
  395.     return (unsigned)len;
  396. }
  397.  
  398.  
  399. LOCAL LVAL XNEAR cattostring(VOIDP)
  400. {
  401.     LVAL tmp,temp,val;
  402.     char XFAR *str;
  403.     unsigned len,i;
  404.     
  405.     /* find resulting length -- also validates argument types */
  406.     len = calclength();
  407.  
  408.     /* create the result string */
  409.     val = newstring(len);
  410.     str = getstring(val);
  411.  
  412.     /* combine the strings */
  413.     while (moreargs()) {
  414.         tmp = nextarg();
  415.         if (!null(tmp)) switch (ntype(tmp)) {
  416.             case STRING: 
  417.                 len = getslength(tmp);
  418.                 MEMCPY(str, getstring(tmp), len);
  419.                 str += len;
  420.                 break;
  421.             case VECTOR:
  422.                 len = getsize(tmp);
  423.                 for (i = 0; i < len; i++) {
  424.                     temp = getelement(tmp,i);
  425.                     if (!charp(temp)) goto failed;
  426.                     *str++ = getchcode(temp);
  427.                 }
  428.                 break;
  429.             case CONS:
  430.                 while (consp(tmp)) {
  431.                     temp = car(tmp);
  432.                     if (!charp(temp)) goto failed;
  433.                     *str++ = getchcode(temp);
  434.                     tmp = cdr(tmp);
  435.                 }
  436.                 break;
  437.         }
  438.     }
  439.  
  440.     *str = 0;   /* delimit string */
  441.  
  442.     /* return the new string */
  443.     return (val);
  444.  
  445. failed:
  446.     xlerror("can't make into string", tmp);
  447.     return (NIL);   /* avoid warning message */
  448. }
  449.  
  450.  
  451. LOCAL LVAL XNEAR cattovector(VOIDP)
  452. {
  453.     LVAL tmp,val;
  454.     LVAL XFAR *vect;
  455.     unsigned len,i;
  456.     
  457.     /* find resulting length -- also validates argument types */
  458.     len = calclength();
  459.  
  460.     /* create the result vector */
  461.     val = newvector(len);
  462.     vect = &val->n_vdata[0];
  463.  
  464.     /* combine the vectors */
  465.     while (moreargs()) {
  466.         tmp = nextarg();
  467.         if (!null(tmp)) switch (ntype(tmp)) {
  468.             case VECTOR: 
  469.                 len = getsize(tmp);
  470.                 MEMCPY(vect, &getelement(tmp,0), len*sizeof(LVAL));
  471.                 vect += len;
  472.                 break;
  473.             case STRING:
  474.                 len = getslength(tmp);
  475.                 for (i = 0; i < len; i++) {
  476.                     *vect++ = cvchar(getstringch(tmp,i));
  477.                 }
  478.                 break;
  479.             case CONS:
  480.                 while (consp(tmp)) {
  481.                     *vect++ = car(tmp);
  482.                     tmp = cdr(tmp);
  483.                 }
  484.                 break;
  485.         }
  486.     }
  487.  
  488.     /* return the new vector */
  489.     return (val);
  490. }
  491.  
  492.  
  493. LOCAL LVAL XNEAR cattocons(VOIDP)
  494. {
  495.     LVAL val,tmp,next,last=NIL;
  496.     unsigned len,i;
  497.     
  498.     xlsave1(val);       /* protect against GC */
  499.     
  500.     /* combine the lists */
  501.     while (moreargs()) {
  502.         tmp = nextarg();
  503.         if (!null(tmp)) switch (ntype(tmp)) {
  504.             case CONS:
  505.                 while (consp(tmp)) {
  506.                     next = consa(car(tmp));
  507.                     if (!null(val)) rplacd(last,next);
  508.                     else val = next;
  509.                     last = next;
  510.                     tmp = cdr(tmp);
  511.                 }
  512.                 break;
  513.             case VECTOR:
  514.                 len = getsize(tmp);
  515.                 for (i = 0; i<len; i++) {
  516.                     next = consa(getelement(tmp,i));
  517.                     if (!null(val)) rplacd(last,next);
  518.                     else val = next;
  519.                     last = next;
  520.                 }
  521.                 break;
  522.             case STRING:
  523.                 len = getslength(tmp);
  524.                 for (i = 0; i < len; i++) {
  525.                     next = consa(cvchar(getstringch(tmp,i)));
  526.                     if (!null(val)) rplacd(last,next);
  527.                     else val = next;
  528.                     last = next;
  529.                 }
  530.                 break;
  531.             default: 
  532.                 xlbadtype(tmp); break; /* need default because no precheck*/
  533.         }
  534.     }
  535.     
  536.     xlpop();
  537.     
  538.     return (val);
  539.  
  540. }
  541.     
  542.  
  543. LVAL xconcatenate()
  544. {
  545.     LVAL tmp;
  546.     
  547.     switch (xlcvttype(tmp = xlgetarg())) {  /* target type of data */
  548.         case CONS:      return cattocons();
  549.         case STRING:    return cattostring();           
  550.         case VECTOR:    return cattovector();
  551.         default:        xlerror("invalid result type", tmp);
  552.                         return (NIL);   /* avoid warning */
  553.     }
  554. }
  555.  
  556. /* xsubseq - return a subsequence -- new version */
  557.  
  558. LVAL xsubseq()
  559. {
  560.     unsigned start,end,len;
  561.     FIXTYPE temp;
  562.     int srctype;
  563.     LVAL src,dst;
  564.     LVAL next,last=NIL;
  565.  
  566.     /* get sequence */
  567.     src = xlgetarg();
  568.     if (listp(src)) srctype = CONS;
  569.     else srctype=ntype(src);
  570.  
  571.     
  572.     /* get length */
  573.     switch (srctype) {
  574.         case STRING:
  575.             len = getslength(src);
  576.             break;
  577.         case VECTOR:
  578.             len = getsize(src);
  579.             break;
  580.         case CONS:      /* BADLY INEFFICIENT! */
  581.             dst = src;  /* use dst as temporary */
  582.             len = 0;
  583.             while (consp(dst)) {
  584.                 dst = cdr(dst);
  585.                 len++; 
  586.                 if (len > MAXSLEN) xltoolong();
  587.             }
  588.             break;
  589.         default:
  590.             xlbadtype(src);
  591.     }
  592.  
  593.     /* get the starting position */
  594.     dst = xlgafixnum(); temp = getfixnum(dst);
  595.     if (temp < 0 || temp > len) 
  596.         xlerror("sequence index out of bounds",dst);
  597.     start = (unsigned) temp;
  598.  
  599.     /* get the ending position */
  600.     if (moreargs()) {
  601.         dst = nextarg();
  602.         if (null(dst)) end = len;
  603.         else if (fixp(dst)) {
  604.             temp = getfixnum(dst);
  605.             if (temp < start || temp > len)
  606.                 xlerror("sequence index out of bounds",dst);
  607.             end = (unsigned) temp;
  608.         }
  609.         else xlbadtype(dst);
  610.     }
  611.     else
  612.         end = len;
  613.     xllastarg();
  614.  
  615.     len = end - start;
  616.     
  617.     switch (srctype) {  /* do the subsequencing */
  618.         case STRING:
  619.             dst = newstring(len);
  620.             MEMCPY(getstring(dst), getstring(src)+start, len);
  621.             dst->n_string[len] = 0;
  622.             break;
  623.         case VECTOR:
  624.             dst = newvector(len);
  625.             MEMCPY(dst->n_vdata, &src->n_vdata[start], sizeof(LVAL)*len);
  626.             break;
  627.         case CONS:
  628.             xlsave1(dst);
  629.             while (start--) src = cdr(src);
  630.             while (len--) {
  631.                 next = consa(car(src));
  632.                 if (!null(dst)) rplacd(last,next);
  633.                 else dst = next;
  634.                 last = next;
  635.                 src = cdr(src);
  636.             }
  637.             xlpop();
  638.             break;
  639.     }
  640.  
  641.     /* return the substring */
  642.     return (dst);
  643. }
  644.  
  645.  
  646. /* xnreverse -- built-in function nreverse (destructive reverse) */
  647. LVAL xnreverse()
  648. {
  649.     LVAL seq,val,next;
  650.     unsigned int i,j;
  651.     int ival;
  652.  
  653.     /* get the sequence to reverse */
  654.     seq = xlgetarg();
  655.     xllastarg();
  656.  
  657.     if (null(seq)) return (NIL);    /* empty argument */
  658.     
  659.     switch (ntype(seq)) {
  660.         case CONS:
  661.             val = NIL;
  662.             while (consp(seq)) {
  663.                 next = cdr(seq);
  664.                 rplacd(seq,val);
  665.                 val = seq;
  666.                 seq = next;
  667.             }
  668.             break;
  669.         case VECTOR:
  670.             if (getsize(seq) > 1)
  671.                 for (i = 0, j = getsize(seq)-1; i < j; i++, j--) {
  672.                     val = getelement(seq,i);
  673.                     setelement(seq,i,getelement(seq,j));
  674.                     setelement(seq,j,val);
  675.                 }
  676.             return seq;
  677.         case STRING:
  678.             if (getslength(seq) > 2)
  679.                 for (i = 0, j=getslength(seq)-1 ; i < j; i++, j--) {
  680.                     ival = seq->n_string[i];
  681.                     seq->n_string[i] = seq->n_string[j];
  682.                     seq->n_string[j] = ival;
  683.                 }
  684.             return seq;
  685.         default: 
  686.             xlbadtype(seq); break;
  687.     }
  688.  
  689.     /* return the sequence */
  690.     return (val);
  691. }
  692.  
  693. /* xreverse - built-in function reverse -- new version */
  694. LVAL xreverse()
  695. {
  696.     LVAL seq,val;
  697.     unsigned i,len;
  698.  
  699.     /* get the sequence to reverse */
  700.     seq = xlgetarg();
  701.     xllastarg();
  702.  
  703.     if (null(seq)) return (NIL);    /* empty argument */
  704.     
  705.     switch (ntype(seq)) {
  706.         case CONS:
  707.             /* protect pointer */
  708.             xlsave1(val);
  709.  
  710.             /* append each element to the head of the result list */
  711.             for (val = NIL; consp(seq); seq = cdr(seq))
  712.                 val = cons(car(seq),val);
  713.  
  714.             /* restore the stack */
  715.             xlpop();
  716.             break;
  717.         case VECTOR:
  718.             len = getsize(seq);
  719.             val = newvector(len);
  720.             for (i = 0; i < len; i++)
  721.                 setelement(val,i,getelement(seq,len-i-1));
  722.             break;
  723.         case STRING:
  724.             len = getslength(seq);
  725.             val = newstring(len);
  726.             for (i = 0; i < len; i++)
  727.                 val->n_string[i] = seq->n_string[len-i-1];
  728.             val->n_string[len] = 0;
  729.             break;
  730.         default: 
  731.             xlbadtype(seq); break;
  732.     }
  733.  
  734.     /* return the sequence */
  735.     return (val);
  736. }
  737.  
  738.  
  739. /* remif - common code for 'remove', 'remove-if', and 'remove-if-not' */
  740. #ifdef ANSI
  741. static LVAL XNEAR remif(int tresult, int expr)
  742. #else
  743. LOCAL LVAL remif(tresult,expr)
  744.   int tresult,expr;
  745. #endif
  746. {
  747.     LVAL x,seq,fcn,val,next;
  748.     LVAL last=NULL;
  749.     unsigned i,j,l;
  750.     unsigned start,end;
  751.     long s;
  752.  
  753. #ifdef KEYARG
  754.     LVAL kfcn;
  755. #endif
  756.  
  757.  
  758.     if (expr) {
  759.         /* get the expression to remove and the sequence */
  760.         x = xlgetarg();
  761.         seq = xlgetarg();
  762.         xltest(&fcn,&tresult);
  763.     }
  764.     else {
  765.         /* get the function and the sequence */
  766.         fcn = xlgetarg();
  767.         seq = xlgetarg();
  768.     }
  769.  
  770.     getseqbounds(&start,&end,getlength(seq),k_start,k_end);
  771.  
  772. #ifdef KEYARG
  773.     kfcn=xlkey();
  774. #endif
  775.  
  776.     xllastarg();
  777.  
  778.     if (null(seq)) return NIL;
  779.  
  780.     /* protect some pointers */
  781.  
  782. #ifdef KEYARG
  783.     xlstkcheck(3);
  784.     xlprotect(kfcn);
  785. #else
  786.     xlstkcheck(2);
  787. #endif
  788.     xlprotect(fcn);
  789.     xlsave(val);
  790.  
  791.     /* remove matches */
  792.     
  793.     switch (ntype(seq)) {
  794.         case CONS:
  795.             for (s=start; end-- > 0; seq = cdr(seq)) {
  796.                         /* check to see if this element should be deleted */
  797.  
  798. #ifdef KEYARG
  799.                 if (s-- > 0 || 
  800.                     (expr?dotest2(x,car(seq),fcn,kfcn)
  801.                     :dotest1(car(seq),fcn,kfcn)) != tresult)
  802. #else
  803.                 if (s-- > 0 || 
  804.                     (expr?dotest2(x,car(seq),fcn)
  805.                     :dotest1(car(seq),fcn)) != tresult)
  806. #endif
  807.                 {
  808.                     next = consa(car(seq));
  809.                     if (!null(val)) rplacd(last,next);
  810.                     else val = next;
  811.                     last = next;
  812.                 }
  813.             }
  814.             /* copy to end */
  815.             while (consp(seq)) {
  816.                 next = consa(car(seq));
  817.                 if (!null(val)) rplacd(last,next);
  818.                 else val = next;
  819.                 last = next;
  820.                 seq = cdr(seq);
  821.             }
  822.             break;
  823.         case VECTOR:
  824.             val = newvector(l=getsize(seq));
  825.             for (i=j=0; i < l; i++) {
  826. #ifdef KEYARG
  827.                 if (i < start || i >= end ||    /* copy if out of range */
  828.                     (expr?dotest2(x,getelement(seq,i),fcn,kfcn)
  829.                     :dotest1(getelement(seq,i),fcn,kfcn)) != tresult)
  830. #else
  831.                 if (i < start || i >= end ||    /* copy if out of range */
  832.                     (expr?dotest2(x,getelement(seq,i),fcn)
  833.                     :dotest1(getelement(seq,i),fcn)) != tresult)
  834. #endif
  835.                 {
  836.                     setelement(val,j++,getelement(seq,i));
  837.                 }
  838.             }
  839.             if (l != j) { /* need new, shorter result -- too bad */
  840.                 fcn = val; /* save value in protected cell */
  841.                 val = newvector(j);
  842.                 MEMCPY(val->n_vdata, fcn->n_vdata, j*sizeof(LVAL));
  843.             }
  844.             break;
  845.         case STRING:
  846.             l = getslength(seq);
  847.             val = newstring(l);
  848.             for (i=j=0; i < l; i++) {
  849. #ifdef KEYARG
  850.                 if (i < start || i >= end ||    /* copy if out of range */
  851.                     (expr?dotest2(x,cvchar(getstringch(seq,i)),fcn,kfcn)
  852.                     :dotest1(cvchar(getstringch(seq,i)),fcn,kfcn))!=tresult)
  853. #else
  854.                 if (i < start || i >= end ||    /* copy if out of range */
  855.                     (expr?dotest2(x,cvchar(getstringch(seq,i)),fcn)
  856.                     :dotest1(cvchar(getstringch(seq,i)),fcn)) != tresult)
  857. #endif
  858.                 {
  859.                     val->n_string[j++] = seq->n_string[i];
  860.                 }
  861.             }
  862.             if (l != j) { /* need new, shorter result -- too bad */
  863.                 fcn = val; /* save value in protected cell */
  864.                 val = newstring(j);
  865.                 MEMCPY(val->n_string, fcn->n_string, j*sizeof(char));
  866.                 val->n_string[j] = 0;
  867.             }
  868.             break;
  869.         default:
  870.             xlbadtype(seq); break;
  871.     }
  872.         
  873.             
  874.     /* restore the stack */
  875. #ifdef KEYARG
  876.     xlpopn(3);
  877. #else
  878.     xlpopn(2);
  879. #endif
  880.  
  881.     /* return the updated sequence */
  882.     return (val);
  883. }
  884.  
  885. /* xremif - built-in function 'remove-if' -- enhanced version */
  886. LVAL xremif()
  887. {
  888.     return (remif(TRUE,FALSE));
  889. }
  890.  
  891. /* xremifnot - built-in function 'remove-if-not' -- enhanced version */
  892. LVAL xremifnot()
  893. {
  894.     return (remif(FALSE,FALSE));
  895. }
  896.  
  897. /* xremove - built-in function 'remove' -- enhanced version */
  898.  
  899. LVAL xremove()
  900. {
  901.     return (remif(TRUE,TRUE));
  902. }
  903.  
  904.  
  905. /* delif - common code for 'delete', 'delete-if', and 'delete-if-not' */
  906. #ifdef ANSI
  907. static LVAL XNEAR delif(int tresult, int expr)
  908. #else
  909. LOCAL LVAL delif(tresult,expr)
  910.   int tresult,expr;
  911. #endif
  912. {
  913.     LVAL x,seq,fcn,last,val;
  914.     unsigned i,j,l;
  915.     unsigned start,end;
  916.  
  917. #ifdef KEYARG
  918.     LVAL kfcn;
  919. #endif
  920.  
  921.  
  922.     if (expr) {
  923.         /* get the expression to delete and the sequence */
  924.         x = xlgetarg();
  925.         seq = xlgetarg();
  926.         xltest(&fcn,&tresult);
  927.     }
  928.     else {
  929.         /* get the function and the sequence */
  930.         fcn = xlgetarg();
  931.         seq = xlgetarg();
  932.     }
  933.  
  934.     getseqbounds(&start,&end,getlength(seq),k_start,k_end);
  935.  
  936.  
  937. #ifdef KEYARG
  938.     kfcn = xlkey();
  939. #endif
  940.  
  941.     xllastarg();
  942.  
  943.     if (null(seq)) return NIL;
  944.  
  945.     /* protect a pointer */
  946.  
  947. #ifdef KEYARG
  948.     xlstkcheck(2);
  949.     xlprotect(kfcn);
  950. #else
  951.     xlstkcheck(1);
  952. #endif
  953.     xlprotect(fcn);
  954.  
  955.     /* delete matches */
  956.     
  957.     switch (ntype(seq)) {
  958.         case CONS:
  959.             end -= start; /* gives length */
  960.             /* delete leading matches, only if start is 0 */
  961.             if (start == 0)
  962.                 while (consp(seq) && end > 0) {
  963.                     end--;
  964. #ifdef KEYARG
  965.                     if ((expr?dotest2(x,car(seq),fcn,kfcn)
  966.                         :dotest1(car(seq),fcn,kfcn)) != tresult)
  967. #else
  968.                     if ((expr?dotest2(x,car(seq),fcn)
  969.                         :dotest1(car(seq),fcn)) != tresult)
  970. #endif
  971.                             break;
  972.                     seq = cdr(seq);
  973.                 }
  974.  
  975.             val = last = seq;
  976.  
  977.             /* delete embedded matches */
  978.             if (consp(seq) && end > 0) {
  979.  
  980.                 /* skip the first non-matching element, start == 0 */
  981.                 if (start == 0) seq = cdr(seq);
  982.  
  983.                 /* skip first elements if start > 0, correct "last" */
  984.                 for (;consp(seq) && start-- > 0;last=seq, seq=cdr(seq)) ;
  985.  
  986.                 /* look for embedded matches */
  987.                 while (consp(seq) && end-- > 0) {
  988.  
  989.                     /* check to see if this element should be deleted */
  990. #ifdef KEYARG
  991.                     if ((expr?dotest2(x,car(seq),fcn,kfcn)
  992.                         :dotest1(car(seq),fcn,kfcn)) == tresult)
  993. #else
  994.                     if ((expr?dotest2(x,car(seq),fcn)
  995.                         :dotest1(car(seq),fcn)) == tresult)
  996. #endif
  997.                         rplacd(last,cdr(seq));
  998.                     else
  999.                         last = seq;
  1000.  
  1001.                     /* move to the next element */
  1002.                     seq = cdr(seq);
  1003.                 }
  1004.             }
  1005.             break;
  1006.         case VECTOR:
  1007.             l = getsize(seq);
  1008.             for (i=j=0; i < l; i++) {
  1009. #ifdef KEYARG
  1010.                 if (i < start || i >= end ||    /* copy if out of range */
  1011.                     (expr?dotest2(x,getelement(seq,i),fcn,kfcn)
  1012.                     :dotest1(getelement(seq,i),fcn,kfcn)) != tresult)
  1013. #else
  1014.                 if (i < start || i >= end ||    /* copy if out of range */
  1015.                     (expr?dotest2(x,getelement(seq,i),fcn)
  1016.                     :dotest1(getelement(seq,i),fcn)) != tresult)
  1017. #endif
  1018.             {
  1019.                     if (i != j) setelement(seq,j,getelement(seq,i));
  1020.                     j++;
  1021.                 }
  1022.             }
  1023.             if (l != j) { /* need new, shorter result -- too bad */
  1024.                 fcn = seq; /* save value in protected cell */
  1025.                 seq = newvector(j);
  1026.                 MEMCPY(seq->n_vdata, fcn->n_vdata, j*sizeof(LVAL));
  1027.             }
  1028.             val = seq;
  1029.             break;
  1030.         case STRING:
  1031.             l = getslength(seq);
  1032.             for (i=j=0; i < l; i++) {
  1033. #ifdef KEYARG
  1034.                 if (i < start || i >= end ||    /* copy if out of range */
  1035.                     (expr?dotest2(x,cvchar(getstringch(seq,i)),fcn,kfcn)
  1036.                     :dotest1(cvchar(getstringch(seq,i)),fcn,kfcn))!=tresult)
  1037. #else
  1038.                 if (i < start || i >= end ||    /* copy if out of range */
  1039.                     (expr?dotest2(x,cvchar(getstringch(seq,i)),fcn)
  1040.                     :dotest1(cvchar(getstringch(seq,i)),fcn)) != tresult)
  1041. #endif
  1042.                 {
  1043.                     if (i != j) seq->n_string[j] = seq->n_string[i];
  1044.                     j++;
  1045.                 }
  1046.             }
  1047.             if (l != j) { /* need new, shorter result -- too bad */
  1048.                 fcn = seq; /* save value in protected cell */
  1049.                 seq = newstring(j);
  1050.                 MEMCPY(seq->n_string, fcn->n_string, j*sizeof(char));
  1051.                 seq->n_string[j] = 0;
  1052.             }
  1053.             val = seq;
  1054.             break;
  1055.         default:
  1056.             xlbadtype(seq); break;
  1057.     }
  1058.         
  1059.             
  1060.     /* restore the stack */
  1061. #ifdef KEYARG
  1062.     xlpopn(2);
  1063. #else
  1064.     xlpop();
  1065. #endif
  1066.  
  1067.     /* return the updated sequence */
  1068.     return (val);
  1069. }
  1070.  
  1071. /* xdelif - built-in function 'delete-if' -- enhanced version */
  1072. LVAL xdelif()
  1073. {
  1074.     return (delif(TRUE,FALSE));
  1075. }
  1076.  
  1077. /* xdelifnot - built-in function 'delete-if-not' -- enhanced version */
  1078. LVAL xdelifnot()
  1079. {
  1080.     return (delif(FALSE,FALSE));
  1081. }
  1082.  
  1083. /* xdelete - built-in function 'delete' -- enhanced version */
  1084.  
  1085. LVAL xdelete()
  1086. {
  1087.     return (delif(TRUE,TRUE));
  1088. }
  1089.  
  1090. #ifdef POSFCNS
  1091. /* xcountif - built-in function 'count-if     TAA MOD addition */
  1092. LVAL xcountif()
  1093. {
  1094.     unsigned counter=0;
  1095.     unsigned start,end;
  1096.     LVAL seq, fcn;
  1097.  
  1098. #ifdef KEYARG
  1099.     LVAL kfcn;
  1100. #endif
  1101.  
  1102.     
  1103.     /* get the arguments */
  1104.     fcn = xlgetarg();
  1105.     seq = xlgetarg();
  1106.  
  1107.     getseqbounds(&start,&end,getlength(seq),k_start,k_end);
  1108.  
  1109. #ifdef KEYARG
  1110.     kfcn = xlkey();
  1111. #endif
  1112.  
  1113.     xllastarg();
  1114.  
  1115.     if (null(seq)) return (cvfixnum((FIXTYPE)0));
  1116.  
  1117. #ifdef KEYARG
  1118.     xlstkcheck(2);
  1119.     xlprotect(kfcn);
  1120. #else
  1121.     xlstkcheck(1);
  1122. #endif
  1123.     xlprotect(fcn);
  1124.  
  1125.     /* examine arg and count */
  1126.     switch (ntype(seq)) {
  1127.         case CONS:
  1128.             end -= start;
  1129.             for (; consp(seq) && start-- > 0; seq = cdr(seq)) ;
  1130.             for (; end-- > 0; seq = cdr(seq))
  1131. #ifdef KEYARG
  1132.                 if (dotest1(car(seq),fcn,kfcn)) counter++;
  1133. #else
  1134.                 if (dotest1(car(seq),fcn)) counter++;
  1135. #endif
  1136.             break;
  1137.         case VECTOR:
  1138.             for (; start < end; start++)
  1139. #ifdef KEYARG
  1140.                 if (dotest1(getelement(seq,start),fcn,kfcn)) counter++;
  1141. #else
  1142.                 if (dotest1(getelement(seq,start),fcn)) counter++;
  1143. #endif
  1144.             break;
  1145.         case STRING:
  1146.             for (; start < end; start++)
  1147. #ifdef KEYARG
  1148.                 if(dotest1(cvchar(getstringch(seq,start)),fcn,kfcn))counter++;
  1149. #else
  1150.                 if (dotest1(cvchar(getstringch(seq,start)),fcn)) counter++;
  1151. #endif
  1152.             break;
  1153.         default:
  1154.             xlbadtype(seq); break;
  1155.     }
  1156.  
  1157. #ifdef KEYARG
  1158.     xlpopn(2);
  1159. #else
  1160.     xlpop();
  1161. #endif
  1162.  
  1163.     return (cvfixnum((FIXTYPE)counter));
  1164. }
  1165.  
  1166. /* xfindif - built-in function 'find-if'    TAA MOD */
  1167. LVAL xfindif()
  1168. {
  1169.     LVAL seq, fcn, val;
  1170.     unsigned start,end;
  1171.     
  1172.  
  1173. #ifdef KEYARG
  1174.     LVAL kfcn;
  1175. #endif
  1176.  
  1177.     fcn = xlgetarg();
  1178.     seq = xlgetarg();
  1179.     
  1180.     getseqbounds(&start,&end,getlength(seq),k_start,k_end);
  1181.  
  1182.  
  1183. #ifdef KEYARG
  1184.     kfcn = xlkey();
  1185. #endif
  1186.  
  1187.     xllastarg();
  1188.  
  1189.     if (null(seq)) return NIL;
  1190.  
  1191. #ifdef KEYARG
  1192.     xlstkcheck(2);
  1193.     xlprotect(kfcn);
  1194. #else
  1195.     xlstkcheck(1);
  1196. #endif
  1197.     xlprotect(fcn);
  1198.  
  1199.     switch (ntype(seq)) {
  1200.         case CONS:
  1201.             end -= start;
  1202.             for (; consp(seq) && start-- > 0; seq = cdr(seq)) ;
  1203.             for (; end-- > 0; seq = cdr(seq)) {
  1204. #ifdef KEYARG
  1205.                 if (dotest1(val=car(seq), fcn, kfcn)) goto fin;
  1206. #else
  1207.                 if (dotest1(val=car(seq), fcn)) goto fin;
  1208. #endif
  1209.             }
  1210.             break;
  1211.         case VECTOR:
  1212.             for (; start < end; start++)
  1213. #ifdef KEYARG
  1214.                 if (dotest1(val=getelement(seq,start),fcn,kfcn)) goto fin;
  1215. #else
  1216.                 if (dotest1(val=getelement(seq,start),fcn)) goto fin;
  1217. #endif
  1218.             break;
  1219.         case STRING:
  1220.             for (; start < end; start++)
  1221. #ifdef KEYARG
  1222.                 if (dotest1(val=cvchar(getstringch(seq,start)),fcn,kfcn))
  1223.                     goto fin;
  1224. #else
  1225.                 if (dotest1(val=cvchar(getstringch(seq,start)),fcn)) goto fin;
  1226. #endif
  1227.             break;
  1228.         default:
  1229.             xlbadtype(seq); break;
  1230.     }
  1231.  
  1232.     val = NIL;  /* not found */
  1233.     
  1234. fin:
  1235. #ifdef KEYARG
  1236.     xlpopn(2);
  1237. #else
  1238.     xlpop();
  1239. #endif
  1240.     return (val);
  1241. }
  1242.  
  1243. /* xpositionif - built-in function 'position-if'    TAA MOD */
  1244. LVAL xpositionif()
  1245. {
  1246.     LVAL seq, fcn;
  1247.     unsigned start,end,count;
  1248.     
  1249. #ifdef KEYARG
  1250.     LVAL kfcn;
  1251. #endif
  1252.  
  1253.     fcn = xlgetarg();
  1254.     seq = xlgetarg();
  1255.     
  1256.     getseqbounds(&start,&end,getlength(seq),k_start,k_end);
  1257.  
  1258. #ifdef KEYARG
  1259.     kfcn = xlkey();
  1260. #endif
  1261.  
  1262.     xllastarg();
  1263.  
  1264.     if (null(seq)) return NIL;
  1265.  
  1266. #ifdef KEYARG
  1267.     xlstkcheck(2);
  1268.     xlprotect(kfcn);
  1269. #else
  1270.     xlstkcheck(1);
  1271. #endif
  1272.     xlprotect(fcn);
  1273.     
  1274.     count = start;
  1275.  
  1276.     switch (ntype(seq)) {
  1277.         case CONS:
  1278.             end -= count;
  1279.             for (; consp(seq) && start-- > 0; seq = cdr(seq)) ;
  1280.             for (; end-- > 0; seq = cdr(seq)) {
  1281. #ifdef KEYARG
  1282.                 if (dotest1(car(seq), fcn, kfcn)) goto fin;
  1283. #else
  1284.                 if (dotest1(car(seq), fcn)) goto fin;
  1285. #endif
  1286.                 count++;
  1287.             }
  1288.             break;
  1289.         case VECTOR:
  1290.             for (; count < end; count++)
  1291. #ifdef KEYARG
  1292.                 if (dotest1(getelement(seq,count),fcn,kfcn)) goto fin;
  1293. #else
  1294.                 if (dotest1(getelement(seq,count),fcn)) goto fin;
  1295. #endif
  1296.             break;
  1297.         case STRING:
  1298.             for (; count < end; count++)
  1299. #ifdef KEYARG
  1300.                 if (dotest1(cvchar(getstringch(seq,count)),fcn,kfcn))goto fin;
  1301. #else
  1302.                 if (dotest1(cvchar(getstringch(seq,count)),fcn)) goto fin;
  1303. #endif
  1304.             break;
  1305.         default:
  1306.             xlbadtype(seq); break;
  1307.     }
  1308.  
  1309.                 /* not found */
  1310. #ifdef KEYARG
  1311.     xlpopn(2);
  1312. #else
  1313.     xlpop();
  1314. #endif
  1315.     return(NIL);
  1316.  
  1317. fin:            /* found */
  1318. #ifdef KEYARG
  1319.     xlpopn(2);
  1320. #else
  1321.     xlpop();
  1322. #endif
  1323.  
  1324.     return (cvfixnum((FIXTYPE)count));
  1325. }
  1326. #endif
  1327.  
  1328. #ifdef SRCHFCN
  1329. /* xsearch -- search function */
  1330.  
  1331. LVAL xsearch()
  1332. {
  1333.     LVAL seq1, seq2, fcn, temp1, temp2;
  1334.     unsigned start1, start2, end1, end2, len1, len2;
  1335.     unsigned i,j;
  1336.     int tresult,typ1, typ2;
  1337. #ifdef KEYARG
  1338.     LVAL kfcn;
  1339. #endif
  1340.     
  1341.     /* get the sequences */
  1342.     seq1 = xlgetarg();  
  1343.     len1 = getlength(seq1);
  1344.     seq2 = xlgetarg();
  1345.     len2 = getlength(seq2);
  1346.  
  1347.     /* test/test-not args? */
  1348.     xltest(&fcn,&tresult);
  1349.  
  1350.     /* check for start/end keys */
  1351.     getseqbounds(&start1,&end1,len1,k_1start,k_1end);
  1352.     getseqbounds(&start2,&end2,len2,k_2start,k_2end);
  1353.     
  1354. #ifdef KEYARG
  1355.     kfcn = xlkey();
  1356. #endif
  1357.  
  1358.     xllastarg();
  1359.  
  1360.     /* calculate the true final search string location that needs to
  1361.         be checked (end2) */
  1362.  
  1363.     if (end2 - start2 < end1 - start1       /* nothing to compare */
  1364.         || end2 - start2 == 0) 
  1365.             return (NIL); 
  1366.  
  1367.     len1 = end1 - start1;   /* calc lengths of sequences to test */
  1368.     end2 -= len1;           /* we don't need to compare with start loc
  1369.                                 beyond this value */
  1370.  
  1371.     typ1 = ntype(seq1);
  1372.     typ2 = ntype(seq2);
  1373.     
  1374. #ifdef KEYARG
  1375.     xlstkcheck(2);
  1376.     xlprotect(kfcn);
  1377. #else
  1378.     xlstkcheck(1);
  1379. #endif
  1380.     xlprotect(fcn);
  1381.  
  1382.     if (typ1 == CONS) { /* skip leading section of sequence 1 if a cons */
  1383.         j = start1;
  1384.         while (j--) seq1 = cdr(seq1);
  1385.     }
  1386.  
  1387.     if (typ2 == CONS) { /* second string is cons */
  1388.         i = start2;     /* skip leading section of string 2 */
  1389.         while (start2--) seq2 = cdr(seq2);
  1390.  
  1391.         for (;i<=end2;i++) {
  1392.             temp2 = seq2;
  1393.             if (typ1 == CONS) {
  1394.                 temp1 = seq1;
  1395.                 for (j = start1; j < end1; j++) {
  1396. #ifdef KEYARG
  1397.                     if (dotest2s(car(temp1),car(temp2),fcn,kfcn) != tresult)
  1398.                         goto next1;
  1399. #else
  1400.                     if (dotest2(car(temp1),car(temp2),fcn) != tresult)
  1401.                         goto next1;
  1402. #endif
  1403.                     temp1 = cdr(temp1);
  1404.                     temp2 = cdr(temp2);
  1405.                 }
  1406.             }
  1407.             else {
  1408.                 for (j = start1; j < end1; j++) {
  1409. #ifdef KEYARG
  1410.                     if (dotest2s(typ1 == VECTOR ? getelement(seq1,j) :
  1411.                         cvchar(getstringch(seq1,j)), car(temp2), fcn, kfcn)
  1412.                         !=tresult)
  1413. #else
  1414.                     if (dotest2(typ1 == VECTOR ? getelement(seq1,j) :
  1415.                        cvchar(getstringch(seq1,j)), car(temp2), fcn)!=tresult)
  1416. #endif
  1417.                         goto next1;
  1418.                     temp2 = cdr(temp2);
  1419.                 }
  1420.             }
  1421. #ifdef KEYARG
  1422.             xlpopn(2);
  1423. #else
  1424.             xlpop();
  1425. #endif
  1426.             return cvfixnum(i);
  1427.             next1: /* continue */
  1428.             seq2 = cdr(seq2);
  1429.         }
  1430.     }
  1431.                 
  1432.     else for (i = start2; i <= end2 ; i++) { /* second string is array/string */
  1433.         if (typ1 == CONS) { 
  1434.             temp1 = seq1;
  1435.             for (j = 0; j < len1; j++) {
  1436. #ifdef KEYARG
  1437.                 if (dotest2s(car(temp1), 
  1438.                             typ2 == VECTOR ? getelement(seq2,i+j) 
  1439.                                            : cvchar(getstringch(seq2,i+j)),
  1440.                             fcn,kfcn) != tresult)
  1441. #else
  1442.                 if (dotest2(car(temp1), 
  1443.                             typ2 == VECTOR ? getelement(seq2,i+j) 
  1444.                                            : cvchar(getstringch(seq2,i+j)),
  1445.                             fcn) != tresult)
  1446. #endif
  1447.                     goto next2;
  1448.                 temp1 = cdr(temp1);
  1449.             }
  1450.         }
  1451.         else for (j=start1; j < end1; j++) {
  1452. #ifdef KEYARG
  1453.             if (dotest2s(typ1 == VECTOR ? 
  1454.                 getelement(seq1,j) : 
  1455.                 cvchar(getstringch(seq1,j)),
  1456.                 typ2 == VECTOR ? 
  1457.                 getelement(seq2,i+j-start1) : 
  1458.                 cvchar(getstringch(seq2,i+j-start1)), fcn, kfcn) 
  1459.                 != tresult)
  1460. #else
  1461.             if (dotest2(typ1 == VECTOR ? 
  1462.                 getelement(seq1,j) : 
  1463.                 cvchar(getstringch(seq1,j)),
  1464.                 typ2 == VECTOR ? 
  1465.                 getelement(seq2,i+j-start1) : 
  1466.                 cvchar(getstringch(seq2,i+j-start1)), fcn) 
  1467.                 != tresult)
  1468. #endif
  1469.                     goto next2;
  1470.         }
  1471. #ifdef KEYARG
  1472.         xlpopn(2);
  1473. #else
  1474.         xlpop();
  1475. #endif
  1476.         return cvfixnum(i);
  1477.         next2:; /* continue */
  1478.     }
  1479.     
  1480. #ifdef KEYARG
  1481.     xlpopn(2);
  1482. #else
  1483.     xlpop();
  1484. #endif
  1485.  
  1486.     return (NIL);   /*no match*/
  1487.  
  1488. }
  1489. #endif
  1490.  
  1491. #ifdef REDUCE
  1492. extern LVAL k_ivalue;
  1493.  
  1494. /* The following is based on code with the following copyright message: */
  1495. /* XLISP-STAT 2.0 Copyright (c) 1988, by Luke Tierney                  */
  1496. /*      All Rights Reserved                                            */
  1497. /*      Permission is granted for unrestricted non-commercial use      */
  1498.  
  1499. /* Extended by Tom Almy to put in a single C function, allow :start and 
  1500.    :end keywords, correctly  handle case of null(seq), and case where
  1501.    sequence is a string */
  1502.  
  1503. /* Common Lisp REDUCE function */
  1504. LVAL xreduce()
  1505. {
  1506.     LVAL fcn, seq, initial_value;
  1507.     LVAL next, args, result;
  1508.     int has_init;
  1509.     unsigned start, end;
  1510.  
  1511.     fcn = xlgetarg();
  1512.     seq = xlgetarg();
  1513.     has_init = xlgetkeyarg(k_ivalue, &initial_value);
  1514.     getseqbounds(&start, &end, getlength(seq), k_start, k_end);
  1515.     xllastarg();
  1516.  
  1517.     /* protect some pointers */
  1518.     xlstkcheck(4);
  1519.     xlsave(next);
  1520.     xlsave(args);
  1521.     xlsave(result);
  1522.     xlprotect(fcn);
  1523.  
  1524.     args = cons(NIL, cons(NIL,NIL));
  1525.  
  1526.     if (null(seq) || start==end) {
  1527.         result = has_init ? initial_value : xlapply(pushargs(fcn, NIL));
  1528.     }
  1529.     else switch (ntype(seq)) {
  1530.         case CONS:
  1531.             end -= start;
  1532.             while (start-- > 0) seq = cdr(seq); /* skip to start */
  1533.             next = seq;
  1534.             if (has_init) result = initial_value;
  1535.             else {
  1536.                 result = car(next);
  1537.                 next = cdr(next);
  1538.                 end--;
  1539.             }
  1540.             for (; end-- > 0; next = cdr(next)) {
  1541.                 rplaca(args, result);
  1542.                 rplaca(cdr(args), car(next));
  1543.                 result = xlapply(pushargs(fcn, args));
  1544.             }
  1545.             break;
  1546.         case VECTOR:
  1547.             if (has_init) 
  1548.                 result = initial_value;
  1549.             else {
  1550.                 result = getelement(seq, start);
  1551.                 start++;
  1552.             }
  1553.             for (; start < end; start++) {
  1554.                 rplaca(args, result);
  1555.                 rplaca(cdr(args), getelement(seq, start));
  1556.                 result = xlapply(pushargs(fcn, args));
  1557.             }
  1558.             break;
  1559.         case STRING:    /* for completeness, darned if I can think of a use */
  1560.             if (has_init) 
  1561.                 result = initial_value;
  1562.             else {
  1563.                 result = cvchar(getstringch(seq, start));
  1564.                 start++;
  1565.             }
  1566.             for (; start < end; start++) {
  1567.                 rplaca(args, result);
  1568.                 rplaca(cdr(args), cvchar(getstringch(seq, start)));
  1569.                 result = xlapply(pushargs(fcn, args));
  1570.             }
  1571.             break;
  1572.         default:
  1573.             xlbadtype(seq);
  1574.         }
  1575.     
  1576.     /* restore the stack frame */
  1577.     xlpopn(4);
  1578.     
  1579.     return(result);
  1580. }
  1581.  
  1582.  
  1583. #endif
  1584.  
  1585. #ifdef REMDUPS
  1586.  
  1587. /* Common Lisp REMOVE-DUPLICATES function */
  1588. /* by Tom Almy */
  1589. /* unlike xllist.c version, this one works on all sequences and 
  1590.    allows the :start and :end keywords. */
  1591.  
  1592. LVAL xremove_duplicates()
  1593. {
  1594.     LVAL seq,fcn,val,next,tmp;
  1595.     LVAL last=NULL;
  1596.     unsigned i,j,l,k;
  1597.     unsigned start,end;
  1598.     int tresult;
  1599.  
  1600. #ifdef KEYARG
  1601.     LVAL kfcn,item;
  1602. #endif
  1603.  
  1604.     /* get the sequence */
  1605.     seq = xlgetarg();
  1606.  
  1607.     /* get any optional args */
  1608.     xltest(&fcn,&tresult);
  1609.  
  1610.     getseqbounds(&start,&end,getlength(seq),k_start,k_end);
  1611.     
  1612. #ifdef KEYARG
  1613.     kfcn = xlkey();
  1614. #endif
  1615.  
  1616.     xllastarg();
  1617.  
  1618.     if (null(seq)) return NIL;
  1619.  
  1620.     /* protect some pointers */
  1621. #ifdef KEYARG
  1622.     xlstkcheck(4);
  1623.     xlprotect(kfcn);
  1624.     xlsave(item);
  1625. #else
  1626.     xlstkcheck(2);
  1627. #endif
  1628.     xlprotect(fcn);
  1629.     xlsave(val);
  1630.  
  1631.     /* remove matches */
  1632.     
  1633.     switch (ntype(seq)) {
  1634.         case CONS:
  1635.             end -= start;   /* length of valid subsequence */
  1636.             while (start-- > 0) {   /* copy leading part intact */
  1637.                 next = consa(car(seq));
  1638.                 if (!null(val)) rplacd(last,next);
  1639.                 else val=next;
  1640.                 last= next;
  1641.             }
  1642.             
  1643.             for (; end-- > 1; seq = cdr(seq)) {
  1644.                 /* check to see if this element should be deleted */
  1645. #ifdef KEYARG
  1646.                 item = car(seq);
  1647.                 if (!null(kfcn)) item = xlapp1(kfcn,item);
  1648.                 for (l=end,tmp=cdr(seq); l-- >0; tmp = cdr(tmp))
  1649.                     if (dotest2(item,car(tmp),fcn,kfcn)==tresult)
  1650.                         goto cons_noxfer;
  1651. #else
  1652.                 for (l=end,tmp=cdr(seq); l-- >0; tmp = cdr(tmp))
  1653.                     if (dotest2(car(seq),car(tmp),fcn)==tresult)
  1654.                         goto cons_noxfer;
  1655. #endif              
  1656.                 next = consa(car(seq));
  1657.                 if (!null(val)) rplacd(last,next);
  1658.                 else val = next;
  1659.                 last = next;
  1660.                 cons_noxfer:;
  1661.             }
  1662.             /* now copy to end */
  1663.             while (consp(seq)) {
  1664.                 next = consa(car(seq));
  1665.                 if (!null(val)) rplacd(last,next);
  1666.                 else val = next;
  1667.                 last = next;
  1668.                 seq = cdr(seq);
  1669.             }
  1670.             break;
  1671.         case VECTOR:
  1672.             val = newvector(l=getsize(seq));
  1673.  
  1674.             if (start>0)
  1675.                 MEMCPY(&getelement(val,0),&getelement(seq,0),start*sizeof(LVAL));
  1676.  
  1677.             for (i=j=0; i < start; i++) setelement(val,j++,getelement(seq,i));
  1678.  
  1679.             for (i=j=start; i < end; i++) {
  1680. #ifdef KEYARG
  1681.                 item = getelement(seq,i);
  1682.                 if (!null(kfcn)) item = xlapp1(kfcn,item);
  1683.                 for (k=i+1; k<end; k++)
  1684.                     if (dotest2(item,getelement(seq,k),fcn,kfcn)==tresult)
  1685.                         goto vector_noxfer;
  1686. #else
  1687.                 for (k=i+1; k<end; k++)
  1688.                     if (dotest2(getelement(seq,i),getelement(seq,k),fcn)==tresult)
  1689.                         goto vector_noxfer;
  1690. #endif
  1691.                 setelement(val,j++,getelement(seq,i));
  1692.                 vector_noxfer:;
  1693.             }
  1694.  
  1695.             if (l-end > 0)
  1696.                 MEMCPY(&getelement(val,end),
  1697.                        &getelement(seq,end),
  1698.                        (l-end)*sizeof(LVAL));
  1699.             
  1700.             if (l != j) { /* need new, shorter result -- too bad */
  1701.                 fcn = val; /* save value in protected cell */
  1702.                 val = newvector(j);
  1703.                 MEMCPY(val->n_vdata, fcn->n_vdata, j*sizeof(LVAL));
  1704.             }
  1705.             break;
  1706.         case STRING:
  1707.             l = getslength(seq);
  1708.             val = newstring(l);
  1709.  
  1710.             MEMCPY(&val->n_string,&seq->n_string,start*sizeof(char));
  1711.             
  1712.             for (i=j=start; i < end; i++) {
  1713. #ifdef KEYARG
  1714.                 item = cvchar(getstringch(seq,i));
  1715.                 if (!null(kfcn)) item = xlapp1(kfcn,item);
  1716.                 for (k=i+1; k<end; k++)
  1717.                     if (dotest2(item,cvchar(getstringch(seq,k)),fcn,kfcn)==tresult)
  1718.                         goto string_noxfer;
  1719. #else
  1720.                 tmp = cvchar(getstringch(seq,i));
  1721.                 for (k=i+1; k<end; k++)
  1722.                     if (dotest2(tmp,cvchar(getstringch(seq,k)),fcn)==tresult)
  1723.                         goto string_noxfer;
  1724. #endif
  1725.                 setstringch(val,j++,getstringch(seq,i));
  1726.                 string_noxfer:;
  1727.             }
  1728.  
  1729.             MEMCPY(&val->n_string[end],&seq->n_string[end],(l-end)*sizeof(char));
  1730.  
  1731.             if (l != j) { /* need new, shorter result -- too bad */
  1732.                 fcn = val; /* save value in protected cell */
  1733.                 val = newstring(j);
  1734.                 MEMCPY(val->n_string, 
  1735.                        fcn->n_string, 
  1736.                        j*sizeof(char));
  1737.                 val->n_string[j] = 0;
  1738.             }
  1739.             break;
  1740.         default:
  1741.             xlbadtype(seq); break;
  1742.     }
  1743.         
  1744.             
  1745.     /* restore the stack */
  1746. #ifdef KEYARG
  1747.     xlpopn(4);
  1748. #else
  1749.     xlpopn(2);
  1750. #endif
  1751.  
  1752.     /* return the updated sequence */
  1753.     return (val);
  1754. }
  1755.  
  1756. #endif
  1757.  
  1758.  
  1759.