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