home *** CD-ROM | disk | FTP | other *** search
/ Fish 'n' More 2 / fishmore-publicdomainlibraryvol.ii1991xetec.iso / dirs / xlispstat_386.lzh / XLispStat / src1.lzh / XLisp / xllist.c < prev    next >
C/C++ Source or Header  |  1990-10-10  |  20KB  |  971 lines
  1. /* xllist.c - xlisp built-in list functions */
  2. /* Copyright (c) 1989, by David Michael Betz.                            */
  3. /* You may give out copies of this software; for conditions see the file */
  4. /* COPYING included with this distribution.                              */
  5.  
  6. #include "xlisp.h"
  7. #include "osdef.h"
  8. #ifdef ANSI
  9. #include "xlproto.h"
  10. #else
  11. #include "xlfun.h"
  12. #endif ANSI
  13.  
  14. /* forward declarations */
  15. #ifdef ANSI
  16. LVAL cxr(char *),nth(int),assoc(LVAL,LVAL,LVAL,int),
  17.      subst(LVAL,LVAL,LVAL,LVAL,int),sublis(LVAL,LVAL,LVAL,int),map(int,int),
  18.      remif(int),delif(int),sortlist(LVAL,LVAL),
  19.      gluelists(LVAL,LVAL,LVAL);
  20. void splitlist(LVAL,LVAL,LVAL *,LVAL *,LVAL);
  21. #else
  22. LVAL cxr(),nth(),assoc(),subst(),sublis(),map(),remif(),delif(),sortlist(),
  23.      gluelists();
  24. void splitlist();
  25. #endif ANSI
  26.  
  27. /* xcar - take the car of a cons cell */
  28. LVAL xcar()
  29. {
  30.     LVAL list;
  31.     list = xlgalist();
  32.     xllastarg();
  33.     return (list ? car(list) : NIL);
  34. }
  35.  
  36. /* xcdr - take the cdr of a cons cell */
  37. LVAL xcdr()
  38. {
  39.     LVAL list;
  40.     list = xlgalist();
  41.     xllastarg();
  42.     return (list ? cdr(list) : NIL);
  43. }
  44.  
  45. /* cxxr functions */
  46. LVAL xcaar() { return (cxr("aa")); }
  47. LVAL xcadr() { return (cxr("da")); }
  48. LVAL xcdar() { return (cxr("ad")); }
  49. LVAL xcddr() { return (cxr("dd")); }
  50.  
  51. /* cxxxr functions */
  52. LVAL xcaaar() { return (cxr("aaa")); }
  53. LVAL xcaadr() { return (cxr("daa")); }
  54. LVAL xcadar() { return (cxr("ada")); }
  55. LVAL xcaddr() { return (cxr("dda")); }
  56. LVAL xcdaar() { return (cxr("aad")); }
  57. LVAL xcdadr() { return (cxr("dad")); }
  58. LVAL xcddar() { return (cxr("add")); }
  59. LVAL xcdddr() { return (cxr("ddd")); }
  60.  
  61. /* cxxxxr functions */
  62. LVAL xcaaaar() { return (cxr("aaaa")); }
  63. LVAL xcaaadr() { return (cxr("daaa")); }
  64. LVAL xcaadar() { return (cxr("adaa")); }
  65. LVAL xcaaddr() { return (cxr("ddaa")); }
  66. LVAL xcadaar() { return (cxr("aada")); }
  67. LVAL xcadadr() { return (cxr("dada")); }
  68. LVAL xcaddar() { return (cxr("adda")); }
  69. LVAL xcadddr() { return (cxr("ddda")); }
  70. LVAL xcdaaar() { return (cxr("aaad")); }
  71. LVAL xcdaadr() { return (cxr("daad")); }
  72. LVAL xcdadar() { return (cxr("adad")); }
  73. LVAL xcdaddr() { return (cxr("ddad")); }
  74. LVAL xcddaar() { return (cxr("aadd")); }
  75. LVAL xcddadr() { return (cxr("dadd")); }
  76. LVAL xcdddar() { return (cxr("addd")); }
  77. LVAL xcddddr() { return (cxr("dddd")); }
  78.  
  79. /* cxr - common car/cdr routine */
  80. LOCAL LVAL cxr(adstr)
  81.   char *adstr;
  82. {
  83.     LVAL list;
  84.  
  85.     /* get the list */
  86.     list = xlgalist();
  87.     xllastarg();
  88.  
  89.     /* perform the car/cdr operations */
  90.     while (*adstr && consp(list))
  91.     list = (*adstr++ == 'a' ? car(list) : cdr(list));
  92.  
  93.     /* make sure the operation succeeded */
  94.     if (*adstr && list)
  95.     xlfail("bad argument");
  96.  
  97.     /* return the result */
  98.     return (list);
  99. }
  100.  
  101. /* xcons - construct a new list cell */
  102. LVAL xcons()
  103. {
  104.     LVAL arg1,arg2;
  105.  
  106.     /* get the two arguments */
  107.     arg1 = xlgetarg();
  108.     arg2 = xlgetarg();
  109.     xllastarg();
  110.  
  111.     /* construct a new list element */
  112.     return (cons(arg1,arg2));
  113. }
  114.  
  115. /* xlist - built a list of the arguments */
  116. LVAL xlist()
  117. {
  118.     LVAL last,next,val;
  119.  
  120.     last = NIL;  /* to keep compilers happy - L. Tierney */
  121.     
  122.     /* protect some pointers */
  123.     xlsave1(val);
  124.  
  125.     /* add each argument to the list */
  126.     for (/*val = NIL*/; moreargs(); ) { /* not needed JKL */
  127.  
  128.     /* append this argument to the end of the list */
  129.     next = consa(nextarg());
  130.     if (val) rplacd(last,next);
  131.     else val = next;
  132.     last = next;
  133.     }
  134.  
  135.     /* restore the stack */
  136.     xlpop();
  137.  
  138.     /* return the list */
  139.     return (val);
  140. }
  141.  
  142. /* xappend - built-in function append */
  143. LVAL xappend()
  144. {
  145.     LVAL list,last,next,val;
  146.     
  147.     /* protect some pointers */
  148.     xlsave1(val);
  149.  
  150.     /* initialize */
  151.     /* val = NIL; not needed JKL */
  152.     last = NIL;  /* to keep compilers happy - L. Tierney */
  153.     
  154.     /* append each argument */
  155.     if (moreargs()) {
  156.     while (xlargc > 1) {
  157.  
  158.         /* append each element of this list to the result list */
  159.         for (list = nextarg(); consp(list); list = cdr(list)) {
  160.         next = consa(car(list));
  161.         if (val) rplacd(last,next);
  162.         else val = next;
  163.         last = next;
  164.         }
  165.     }
  166.  
  167.     /* handle the last argument */
  168.     if (val) rplacd(last,nextarg());
  169.     else val = nextarg();
  170.     }
  171.  
  172.     /* restore the stack */
  173.     xlpop();
  174.  
  175.     /* return the list */
  176.     return (val);
  177. }
  178.  
  179. /* xreverse - built-in function reverse */
  180. LVAL xreverse()
  181. {
  182.     LVAL list,val;
  183.  
  184.     /* protect some pointers */
  185.     xlsave1(val);
  186.  
  187.     /* get the list to reverse */
  188.     list = xlgalist();
  189.     xllastarg();
  190.  
  191.     /* append each element to the head of the result list */
  192.     for (val = NIL; consp(list); list = cdr(list))
  193.     val = cons(car(list),val);
  194.  
  195.     /* restore the stack */
  196.     xlpop();
  197.  
  198.     /* return the list */
  199.     return (val);
  200. }
  201.  
  202. /* xlast - return the last cons of a list */
  203. LVAL xlast()
  204. {
  205.     LVAL list;
  206.  
  207.     /* get the list */
  208.     list = xlgalist();
  209.     xllastarg();
  210.  
  211.     /* find the last cons */
  212.     while (consp(list) && cdr(list))
  213.     list = cdr(list);
  214.  
  215.     /* return the last element */
  216.     return (list);
  217. }
  218.  
  219. /* xmember - built-in function 'member' */
  220. LVAL xmember()
  221. {
  222.     LVAL x,list,fcn,val;
  223.     int tresult;
  224.  
  225.     /* protect some pointers */
  226.     xlsave1(fcn);
  227.  
  228.     /* get the expression to look for and the list */
  229.     x = xlgetarg();
  230.     list = xlgalist();
  231.     xltest(&fcn,&tresult);
  232.  
  233.     /* look for the expression */
  234.     for (val = NIL; consp(list); list = cdr(list))
  235.     if (dotest2(x,car(list),fcn) == tresult) {
  236.         val = list;
  237.         break;
  238.     }
  239.  
  240.     /* restore the stack */
  241.     xlpop();
  242.  
  243.     /* return the result */
  244.     return (val);
  245. }
  246.  
  247. /* xassoc - built-in function 'assoc' */
  248. LVAL xassoc()
  249. {
  250.     LVAL x,alist,fcn,pair,val;
  251.     int tresult;
  252.  
  253.     /* protect some pointers */
  254.     xlsave1(fcn);
  255.  
  256.     /* get the expression to look for and the association list */
  257.     x = xlgetarg();
  258.     alist = xlgalist();
  259.     xltest(&fcn,&tresult);
  260.  
  261.     /* look for the expression */
  262.     for (val = NIL; consp(alist); alist = cdr(alist))
  263.     if ((pair = car(alist)) && consp(pair))
  264.         if (dotest2(x,car(pair),fcn) == tresult) {
  265.         val = pair;
  266.         break;
  267.         }
  268.  
  269.     /* restore the stack */
  270.     xlpop();
  271.  
  272.     /* return result */
  273.     return (val);
  274. }
  275.  
  276. /* xsubst - substitute one expression for another */
  277. LVAL xsubst()
  278. {
  279.     LVAL to,from,expr,fcn,val;
  280.     int tresult;
  281.  
  282.     /* protect some pointers */
  283.     xlsave1(fcn);
  284.  
  285.     /* get the to value, the from value and the expression */
  286.     to = xlgetarg();
  287.     from = xlgetarg();
  288.     expr = xlgetarg();
  289.     xltest(&fcn,&tresult);
  290.  
  291.     /* do the substitution */
  292.     val = subst(to,from,expr,fcn,tresult);
  293.  
  294.     /* restore the stack */
  295.     xlpop();
  296.  
  297.     /* return the result */
  298.     return (val);
  299. }
  300.  
  301. /* subst - substitute one expression for another */
  302. LOCAL LVAL subst(to,from,expr,fcn,tresult)
  303.   LVAL to,from,expr,fcn; int tresult;
  304. {
  305.     LVAL carval,cdrval;
  306.  
  307.     if (dotest2(expr,from,fcn) == tresult)
  308.     return (to);
  309.     else if (consp(expr)) {
  310.     xlsave1(carval);
  311.     carval = subst(to,from,car(expr),fcn,tresult);
  312.     cdrval = subst(to,from,cdr(expr),fcn,tresult);
  313.     xlpop();
  314.     return (cons(carval,cdrval));
  315.     }
  316.     else
  317.     return (expr);
  318. }
  319.  
  320. /* xsublis - substitute using an association list */
  321. LVAL xsublis()
  322. {
  323.     LVAL alist,expr,fcn,val;
  324.     int tresult;
  325.  
  326.     /* protect some pointers */
  327.     xlsave1(fcn);
  328.  
  329.     /* get the assocation list and the expression */
  330.     alist = xlgalist();
  331.     expr = xlgetarg();
  332.     xltest(&fcn,&tresult);
  333.  
  334.     /* do the substitution */
  335.     val = sublis(alist,expr,fcn,tresult);
  336.  
  337.     /* restore the stack */
  338.     xlpop();
  339.  
  340.     /* return the result */
  341.     return (val);
  342. }
  343.  
  344. /* sublis - substitute using an association list */
  345. LOCAL LVAL sublis(alist,expr,fcn,tresult)
  346.   LVAL alist,expr,fcn; int tresult;
  347. {
  348.     LVAL carval,cdrval,pair;
  349.  
  350.     if (pair = assoc(expr,alist,fcn,tresult))
  351.     return (cdr(pair));
  352.     else if (consp(expr)) {
  353.     xlsave1(carval);
  354.     carval = sublis(alist,car(expr),fcn,tresult);
  355.     cdrval = sublis(alist,cdr(expr),fcn,tresult);
  356.     xlpop();
  357.     return (cons(carval,cdrval));
  358.     }
  359.     else
  360.     return (expr);
  361. }
  362.  
  363. /* assoc - find a pair in an association list */
  364. LOCAL LVAL assoc(expr,alist,fcn,tresult)
  365.   LVAL expr,alist,fcn; int tresult;
  366. {
  367.     LVAL pair;
  368.  
  369.     for (; consp(alist); alist = cdr(alist))
  370.     if ((pair = car(alist)) && consp(pair))
  371.         if (dotest2(expr,car(pair),fcn) == tresult)
  372.         return (pair);
  373.     return (NIL);
  374. }
  375.  
  376. /* xremove - built-in function 'remove' */
  377. LVAL xremove()
  378. {
  379.     LVAL x,list,fcn,val,last,next;
  380.     int tresult;
  381.  
  382.     last = NIL;  /* to keep compilers happy - L. Tierney */
  383.     
  384.     /* protect some pointers */
  385.     xlstkcheck(2);
  386.     xlsave(fcn);
  387.     xlsave(val);
  388.  
  389.     /* get the expression to remove and the list */
  390.     x = xlgetarg();
  391.     list = xlgalist();
  392.     xltest(&fcn,&tresult);
  393.  
  394.     /* remove matches */
  395.     for (; consp(list); list = cdr(list))
  396.  
  397.     /* check to see if this element should be deleted */
  398.     if (dotest2(x,car(list),fcn) != tresult) {
  399.         next = consa(car(list));
  400.         if (val) rplacd(last,next);
  401.         else val = next;
  402.         last = next;
  403.     }
  404.  
  405.     /* restore the stack */
  406.     xlpopn(2);
  407.  
  408.     /* return the updated list */
  409.     return (val);
  410. }
  411.  
  412. /* xremif - built-in function 'remove-if' */
  413. LVAL xremif()
  414. {
  415.     LVAL remif();
  416.     return (remif(TRUE));
  417. }
  418.  
  419. /* xremifnot - built-in function 'remove-if-not' */
  420. LVAL xremifnot()
  421. {
  422.     LVAL remif();
  423.     return (remif(FALSE));
  424. }
  425.  
  426. /* remif - common code for 'remove-if' and 'remove-if-not' */
  427. LOCAL LVAL remif(tresult)
  428.   int tresult;
  429. {
  430.     LVAL list,fcn,val,last,next;
  431.  
  432.     last = NIL;  /* to keep compilers happy - L. Tierney */
  433.     
  434.     /* protect some pointers */
  435.     xlstkcheck(2);
  436.     xlsave(fcn);
  437.     xlsave(val);
  438.  
  439.     /* get the expression to remove and the list */
  440.     fcn = xlgetarg();
  441.     list = xlgalist();
  442.     xllastarg();
  443.  
  444.     /* remove matches */
  445.     for (; consp(list); list = cdr(list))
  446.  
  447.     /* check to see if this element should be deleted */
  448.     if (dotest1(car(list),fcn) != tresult) {
  449.         next = consa(car(list));
  450.         if (val) rplacd(last,next);
  451.         else val = next;
  452.         last = next;
  453.     }
  454.  
  455.     /* restore the stack */
  456.     xlpopn(2);
  457.  
  458.     /* return the updated list */
  459.     return (val);
  460. }
  461.  
  462. /* dotest1 - call a test function with one argument */
  463. int dotest1(arg,fun)
  464.   LVAL arg,fun;
  465. {
  466.     LVAL *newfp;
  467.  
  468.     /* create the new call frame */
  469.     newfp = xlsp;
  470.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  471.     pusharg(fun);
  472.     pusharg(cvfixnum((FIXTYPE)1));
  473.     pusharg(arg);
  474.     xlfp = newfp;
  475.  
  476.     /* return the result of applying the test function */
  477.     return (xlapply(1) != NIL);
  478.  
  479. }
  480.  
  481. /* dotest2 - call a test function with two arguments */
  482. int dotest2(arg1,arg2,fun)
  483.   LVAL arg1,arg2,fun;
  484. {
  485.     LVAL *newfp;
  486.  
  487.     /* create the new call frame */
  488.     newfp = xlsp;
  489.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  490.     pusharg(fun);
  491.     pusharg(cvfixnum((FIXTYPE)2));
  492.     pusharg(arg1);
  493.     pusharg(arg2);
  494.     xlfp = newfp;
  495.  
  496.     /* return the result of applying the test function */
  497.     return (xlapply(2) != NIL);
  498.  
  499. }
  500.  
  501. /* xnth - return the nth element of a list */
  502. LVAL xnth()
  503. {
  504.     return (nth(TRUE));
  505. }
  506.  
  507. /* xnthcdr - return the nth cdr of a list */
  508. LVAL xnthcdr()
  509. {
  510.     return (nth(FALSE));
  511. }
  512.  
  513. /* nth - internal nth function */
  514. LOCAL LVAL nth(carflag)
  515.   int carflag;
  516. {
  517.     LVAL list,num;
  518.     FIXTYPE n;
  519.  
  520.     /* get n and the list */
  521.     num = xlgafixnum();
  522.     list = xlgacons();
  523.     xllastarg();
  524.  
  525.     /* make sure the number isn't negative */
  526.     if ((n = getfixnum(num)) < 0)
  527.     xlfail("bad argument");
  528.  
  529.     /* find the nth element */
  530.     while (consp(list) && --n >= 0)
  531.     list = cdr(list);
  532.  
  533.     /* return the list beginning at the nth element */
  534.     return (carflag && consp(list) ? car(list) : list);
  535. }
  536.  
  537. /* xlength - return the length of a list or string */
  538. LVAL xlength()
  539. {
  540.     FIXTYPE n;
  541.     LVAL arg;
  542.  
  543.     /* get the list or string */
  544.     arg = xlgetarg();
  545.     xllastarg();
  546.  
  547.     /* find the length of a list */
  548.     if (listp(arg))
  549.     for (n = 0; consp(arg); n++)
  550.         arg = cdr(arg);
  551.  
  552.     /* find the length of a string */
  553.     else if (stringp(arg))
  554.     n = (FIXTYPE)getslength(arg)-1;
  555.  
  556.     /* find the length of a vector */
  557.     else if (vectorp(arg))
  558.     n = (FIXTYPE)getsize(arg);
  559.  
  560.     /* otherwise, bad argument type */
  561.     else
  562.     xlerror("bad argument type",arg);
  563.  
  564.     /* return the length */
  565.     return (cvfixnum(n));
  566. }
  567.  
  568. /* xmapc - built-in function 'mapc' */
  569. LVAL xmapc()
  570. {
  571.     return (map(TRUE,FALSE));
  572. }
  573.  
  574. /* xmapcar - built-in function 'mapcar' */
  575. LVAL xmapcar()
  576. {
  577.     return (map(TRUE,TRUE));
  578. }
  579.  
  580. /* xmapl - built-in function 'mapl' */
  581. LVAL xmapl()
  582. {
  583.     return (map(FALSE,FALSE));
  584. }
  585.  
  586. /* xmaplist - built-in function 'maplist' */
  587. LVAL xmaplist()
  588. {
  589.     return (map(FALSE,TRUE));
  590. }
  591.  
  592. /* map - internal mapping function */
  593. LOCAL LVAL map(carflag,valflag)
  594.   int carflag,valflag;
  595. {
  596.     LVAL *newfp,fun,lists,val,last,p,x,y;
  597.     int argc;
  598.  
  599.     /* protect some pointers */
  600.     xlstkcheck(3);
  601.     xlsave(fun);
  602.     xlsave(lists);
  603.     xlsave(val);
  604.  
  605.     /* get the function to apply and the first list */
  606.     fun = xlgetarg();
  607.     lists = xlgalist();
  608.  
  609.     /* initialize the result list */
  610.     val = (valflag ? NIL : lists);
  611.  
  612.     /* build a list of argument lists */
  613.     for (lists = last = consa(lists); moreargs(); last = cdr(last))
  614.     rplacd(last,cons(xlgalist(),NIL));
  615.  
  616.     /* loop through each of the argument lists */
  617.     for (;;) {
  618.  
  619.     /* build an argument list from the sublists */
  620.     newfp = xlsp;
  621.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  622.     pusharg(fun);
  623.     pusharg(NIL);
  624.     argc = 0;
  625.     for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
  626.         pusharg(carflag ? car(y) : y);
  627.         rplaca(x,cdr(y));
  628.         ++argc;
  629.     }
  630.  
  631.     /* quit if any of the lists were empty */
  632.     if (x) {
  633.         xlsp = newfp;
  634.         break;
  635.     }
  636.  
  637.     /* apply the function to the arguments */
  638.     newfp[2] = cvfixnum((FIXTYPE)argc);
  639.     xlfp = newfp;
  640.     if (valflag) {
  641.         p = consa(xlapply(argc));
  642.         if (val) rplacd(last,p);
  643.         else val = p;
  644.         last = p;
  645.     }
  646.     else
  647.         xlapply(argc);
  648.     }
  649.  
  650.     /* restore the stack */
  651.     xlpopn(3);
  652.  
  653.     /* return the last test expression value */
  654.     return (val);
  655. }
  656.  
  657. /* xrplca - replace the car of a list node */
  658. LVAL xrplca()
  659. {
  660.     LVAL list,newcar;
  661.  
  662.     /* get the list and the new car */
  663.     list = xlgacons();
  664.     newcar = xlgetarg();
  665.     xllastarg();
  666.  
  667.     /* replace the car */
  668.     rplaca(list,newcar);
  669.  
  670.     /* return the list node that was modified */
  671.     return (list);
  672. }
  673.  
  674. /* xrplcd - replace the cdr of a list node */
  675. LVAL xrplcd()
  676. {
  677.     LVAL list,newcdr;
  678.  
  679.     /* get the list and the new cdr */
  680.     list = xlgacons();
  681.     newcdr = xlgetarg();
  682.     xllastarg();
  683.  
  684.     /* replace the cdr */
  685.     rplacd(list,newcdr);
  686.  
  687.     /* return the list node that was modified */
  688.     return (list);
  689. }
  690.  
  691. /* xnconc - destructively append lists */
  692. LVAL xnconc()
  693. {
  694.     LVAL next,last,val;
  695.     
  696.     /* initialize */
  697.     val = NIL;
  698.     last = NIL;  /* to keep compilers happy - L. Tierney */
  699.     
  700.     /* concatenate each argument */
  701.     if (moreargs()) {
  702.     while (xlargc > 1) {
  703.  
  704.         /* ignore everything except lists */
  705.         if ((next = nextarg()) && consp(next)) {
  706.  
  707.         /* concatenate this list to the result list */
  708.         if (val) rplacd(last,next);
  709.         else val = next;
  710.  
  711.         /* find the end of the list */
  712.         while (consp(cdr(next)))
  713.             next = cdr(next);
  714.         last = next;
  715.         }
  716.     }
  717.  
  718.     /* handle the last argument */
  719.     if (val) rplacd(last,nextarg());
  720.     else val = nextarg();
  721.     }
  722.  
  723.     /* return the list */
  724.     return (val);
  725. }
  726.  
  727. /* xdelete - built-in function 'delete' */
  728. LVAL xdelete()
  729. {
  730.     LVAL x,list,fcn,last,val;
  731.     int tresult;
  732.  
  733.     /* protect some pointers */
  734.     xlsave1(fcn);
  735.  
  736.     /* get the expression to delete and the list */
  737.     x = xlgetarg();
  738.     list = xlgalist();
  739.     xltest(&fcn,&tresult);
  740.  
  741.     /* delete leading matches */
  742.     while (consp(list)) {
  743.     if (dotest2(x,car(list),fcn) != tresult)
  744.         break;
  745.     list = cdr(list);
  746.     }
  747.     val = last = list;
  748.  
  749.     /* delete embedded matches */
  750.     if (consp(list)) {
  751.  
  752.     /* skip the first non-matching element */
  753.     list = cdr(list);
  754.  
  755.     /* look for embedded matches */
  756.     while (consp(list)) {
  757.  
  758.         /* check to see if this element should be deleted */
  759.         if (dotest2(x,car(list),fcn) == tresult)
  760.         rplacd(last,cdr(list));
  761.         else
  762.         last = list;
  763.  
  764.         /* move to the next element */
  765.         list = cdr(list);
  766.      }
  767.     }
  768.  
  769.     /* restore the stack */
  770.     xlpop();
  771.  
  772.     /* return the updated list */
  773.     return (val);
  774. }
  775.  
  776. /* xdelif - built-in function 'delete-if' */
  777. LVAL xdelif()
  778. {
  779.     LVAL delif();
  780.     return (delif(TRUE));
  781. }
  782.  
  783. /* xdelifnot - built-in function 'delete-if-not' */
  784. LVAL xdelifnot()
  785. {
  786.     LVAL delif();
  787.     return (delif(FALSE));
  788. }
  789.  
  790. /* delif - common routine for 'delete-if' and 'delete-if-not' */
  791. LOCAL LVAL delif(tresult)
  792.   int tresult;
  793. {
  794.     LVAL list,fcn,last,val;
  795.  
  796.     /* protect some pointers */
  797.     xlsave1(fcn);
  798.  
  799.     /* get the expression to delete and the list */
  800.     fcn = xlgetarg();
  801.     list = xlgalist();
  802.     xllastarg();
  803.  
  804.     /* delete leading matches */
  805.     while (consp(list)) {
  806.     if (dotest1(car(list),fcn) != tresult)
  807.         break;
  808.     list = cdr(list);
  809.     }
  810.     val = last = list;
  811.  
  812.     /* delete embedded matches */
  813.     if (consp(list)) {
  814.  
  815.     /* skip the first non-matching element */
  816.     list = cdr(list);
  817.  
  818.     /* look for embedded matches */
  819.     while (consp(list)) {
  820.  
  821.         /* check to see if this element should be deleted */
  822.         if (dotest1(car(list),fcn) == tresult)
  823.         rplacd(last,cdr(list));
  824.         else
  825.         last = list;
  826.  
  827.         /* move to the next element */
  828.         list = cdr(list);
  829.      }
  830.     }
  831.  
  832.     /* restore the stack */
  833.     xlpop();
  834.  
  835.     /* return the updated list */
  836.     return (val);
  837. }
  838.  
  839. /* xsort - built-in function 'sort' */
  840. LVAL xsort()
  841. {
  842.     LVAL sortlist();
  843.     LVAL list,fcn;
  844.  
  845.     /* protect some pointers */
  846.     xlstkcheck(2);
  847.     xlsave(list);
  848.     xlsave(fcn);
  849.  
  850.     /* get the list to sort and the comparison function */
  851.     list = xlgalist();
  852.     fcn = xlgetarg();
  853.     xllastarg();
  854.  
  855.     /* sort the list */
  856.     list = sortlist(list,fcn);
  857.  
  858.     /* restore the stack and return the sorted list */
  859.     xlpopn(2);
  860.     return (list);
  861. }
  862.  
  863. /*
  864.     This sorting algorithm is based on a Modula-2 sort written by
  865.     Richie Bielak and published in the February 1988 issue of
  866.     "Computer Language" magazine in a letter to the editor.
  867. */
  868.  
  869. /* sortlist - sort a list using quicksort */
  870. LOCAL LVAL sortlist(list,fcn)
  871.   LVAL list,fcn;
  872. {
  873.     LVAL gluelists();
  874.     LVAL smaller,pivot,larger;
  875.     
  876.     /* protect some pointers */
  877.     xlstkcheck(3);
  878.     xlsave(smaller);
  879.     xlsave(pivot);
  880.     xlsave(larger);
  881.     
  882.     /* lists with zero or one element are already sorted */
  883.     if (consp(list) && consp(cdr(list))) {
  884.     pivot = list; list = cdr(list);
  885.     splitlist(pivot,list,&smaller,&larger,fcn);
  886.     smaller = sortlist(smaller,fcn);
  887.     larger = sortlist(larger,fcn);
  888.     list = gluelists(smaller,pivot,larger);
  889.     }
  890.  
  891.     /* cleanup the stack and return the sorted list */
  892.     xlpopn(3);
  893.     return (list);
  894. }
  895.  
  896. /* splitlist - split the list around the pivot */
  897. #ifdef DODO
  898. LOCAL void splitlist(pivot,list,psmaller,plarger,fcn)
  899.   LVAL pivot,list,*psmaller,*plarger,fcn;
  900. {
  901.     LVAL next;
  902.     
  903.     /* initialize the result lists */
  904.     *psmaller = *plarger = NIL;
  905.     
  906.     /* split the list */
  907.     for (; consp(list); list = next) {
  908.     next = cdr(list);
  909.     if (dotest2(car(list),car(pivot),fcn)) {
  910.         rplacd(list,*psmaller);
  911.         *psmaller = list;
  912.     }
  913.     else {
  914.         rplacd(list,*plarger);
  915.         *plarger = list;
  916.     }
  917.     }
  918. }
  919. #else
  920. LOCAL void splitlist(pivot,list,psmaller,plarger,fcn)
  921.   LVAL pivot,list,*psmaller,*plarger,fcn;
  922. {
  923.   LVAL next, smaller, larger;
  924.     
  925.   xlstkcheck(4);
  926.   xlprotect(list);
  927.   xlprotect(pivot);
  928.   xlsave(smaller);
  929.   xlsave(larger);
  930.   
  931.   /* initialize the result lists */
  932.   /* smaller = larger = NIL; not needed JKL */
  933.     
  934.   /* split the list */
  935.   for (; consp(list); list = next) {
  936.     next = cdr(list);
  937.     if (dotest2(car(list),car(pivot),fcn)) {
  938.       rplacd(list, smaller);
  939.       smaller = list;
  940.     }
  941.     else {
  942.       rplacd(list, larger);
  943.       larger = list;
  944.     }
  945.   }
  946.   xlpopn(4);
  947.   *psmaller = smaller;
  948.   *plarger = larger;
  949. }
  950. #endif DODO
  951.  
  952. /* gluelists - glue the smaller and larger lists with the pivot */
  953. LOCAL LVAL gluelists(smaller,pivot,larger)
  954.   LVAL smaller,pivot,larger;
  955. {
  956.     LVAL last;
  957.     
  958.     /* larger always goes after the pivot */
  959.     rplacd(pivot,larger);
  960.  
  961.     /* if the smaller list is empty, we're done */
  962.     if (null(smaller))
  963.     return (pivot);
  964.  
  965.     /* append the smaller to the front of the resulting list */
  966.     for (last = smaller; consp(cdr(last)); last = cdr(last))
  967.     ;
  968.     rplacd(last,pivot);
  969.     return (smaller);
  970. }
  971.