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