home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / windows / c / xlisp21w / sources / xllist.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-08  |  30.6 KB  |  1,389 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 ANSI
  10. LVAL XNEAR cxr(char *adstr);
  11. LVAL XNEAR nth(int charflag);
  12. #ifdef KEYARG
  13. LVAL XNEAR assoc(LVAL expr, LVAL alist, LVAL fcn, LVAL kfcn, int tresult);
  14. LVAL XNEAR subst(LVAL to, LVAL from, LVAL expr, LVAL fcn, LVAL kfcn, int tresult);
  15. LVAL XNEAR sublis(LVAL alist, LVAL expr, LVAL fcn, LVAL kfcn, int tresult);
  16. #ifdef SETS
  17. LVAL XNEAR membr(LVAL expr,LVAL list,LVAL fcn,LVAL kfcn,int tresult);
  18. #endif
  19. #else
  20. LVAL XNEAR assoc(LVAL expr, LVAL alist, LVAL fcn, int tresult);
  21. LVAL XNEAR subst(LVAL to, LVAL from, LVAL expr, LVAL fcn, int tresult);
  22. LVAL XNEAR sublis(LVAL alist, LVAL expr, LVAL fcn, int tresult);
  23. #ifdef SETS
  24. LVAL XNEAR membr(LVAL expr,LVAL list,LVAL fcn,int tresult);
  25. #endif
  26. #endif
  27. void XNEAR splitlist(LVAL pivot,LVAL list, LVAL *psmaller, LVAL *plarger, LVAL fcn);
  28. #else
  29. FORWARD LVAL cxr();
  30. FORWARD LVAL nth(),assoc();
  31. FORWARD LVAL subst(),sublis();
  32. FORWARD VOID splitlist();
  33. #endif
  34.  
  35. /* external declarations  TAA MOD for circular list catching */
  36. extern long nnodes;
  37.  
  38. /* xlcircular -- circular list error */
  39. VOID XNEAR xlcircular(VOIDP)
  40. {
  41.     xlfail("circular list");
  42. }
  43.  
  44. /* xcar - take the car of a cons cell */
  45. LVAL xcar()
  46. {
  47.     LVAL list;
  48.     list = xlgalist();
  49.     xllastarg();
  50.     return (null(list) ? NIL : car(list));
  51. }
  52.  
  53. /* xcdr - take the cdr of a cons cell */
  54. LVAL xcdr()
  55. {
  56.     LVAL list;
  57.     list = xlgalist();
  58.     xllastarg();
  59.     return (null(list) ? NIL : cdr(list));
  60. }
  61.  
  62. /* cxxr functions */
  63. LVAL xcaar() { return (cxr("aa")); }
  64. LVAL xcadr() { return (cxr("da")); }
  65. LVAL xcdar() { return (cxr("ad")); }
  66. LVAL xcddr() { return (cxr("dd")); }
  67.  
  68. /* cxxxr functions */
  69. LVAL xcaaar() { return (cxr("aaa")); }
  70. LVAL xcaadr() { return (cxr("daa")); }
  71. LVAL xcadar() { return (cxr("ada")); }
  72. LVAL xcaddr() { return (cxr("dda")); }
  73. LVAL xcdaar() { return (cxr("aad")); }
  74. LVAL xcdadr() { return (cxr("dad")); }
  75. LVAL xcddar() { return (cxr("add")); }
  76. LVAL xcdddr() { return (cxr("ddd")); }
  77.  
  78. /* cxxxxr functions */
  79. LVAL xcaaaar() { return (cxr("aaaa")); }
  80. LVAL xcaaadr() { return (cxr("daaa")); }
  81. LVAL xcaadar() { return (cxr("adaa")); }
  82. LVAL xcaaddr() { return (cxr("ddaa")); }
  83. LVAL xcadaar() { return (cxr("aada")); }
  84. LVAL xcadadr() { return (cxr("dada")); }
  85. LVAL xcaddar() { return (cxr("adda")); }
  86. LVAL xcadddr() { return (cxr("ddda")); }
  87. LVAL xcdaaar() { return (cxr("aaad")); }
  88. LVAL xcdaadr() { return (cxr("daad")); }
  89. LVAL xcdadar() { return (cxr("adad")); }
  90. LVAL xcdaddr() { return (cxr("ddad")); }
  91. LVAL xcddaar() { return (cxr("aadd")); }
  92. LVAL xcddadr() { return (cxr("dadd")); }
  93. LVAL xcdddar() { return (cxr("addd")); }
  94. LVAL xcddddr() { return (cxr("dddd")); }
  95.  
  96. /* cxr - common car/cdr routine */
  97. LOCAL LVAL XNEAR cxr(adstr)
  98.   char *adstr;
  99. {
  100.     LVAL list;
  101.  
  102.     /* get the list */
  103.     list = xlgalist();
  104.  
  105.     xllastarg();
  106.  
  107.     /* perform the car/cdr operations */
  108.     while (*adstr && consp(list))
  109.         list = (*adstr++ == 'a' ? car(list) : cdr(list));
  110.  
  111.     /* make sure the operation succeeded */
  112.     if (*adstr && !null(list))
  113.         xlfail("bad argument");
  114.  
  115.     /* return the result */
  116.     return (list);
  117. }
  118.  
  119. /* xcons - construct a new list cell */
  120. LVAL xcons()
  121. {
  122.     LVAL arg1,arg2;
  123.  
  124.     /* get the two arguments */
  125.     arg1 = xlgetarg();
  126.     arg2 = xlgetarg();
  127.     xllastarg();
  128.  
  129.     /* construct a new list element */
  130.     return (cons(arg1,arg2));
  131. }
  132.  
  133. /* xlist - built a list of the arguments */
  134. /* Rewritten by TAA for compactness and speed */
  135. LVAL xlist()
  136. {
  137.     LVAL val;
  138.     int i=xlargc;
  139.  
  140.     /* protect a pointer */
  141.     xlsave1(val);
  142.  
  143.     /* do the work */
  144.     while (i-- > 0)
  145.         val = cons(xlargv[i],val);
  146.  
  147.     /* restore the stack */
  148.     xlpop();
  149.  
  150.     /* return the list */
  151.     return (val);
  152. }
  153.  
  154. /* xliststar - built a list of the arguments */
  155. /* by TAA */
  156. LVAL xliststar()
  157. {
  158.     LVAL val;
  159.     int i=xlargc;
  160.  
  161.     if (i==0) xltoofew();   /* must have at least one argument */
  162.  
  163.     /* protect a pointer */
  164.     xlprot1(val);
  165.  
  166.     /* last argument is list tail */
  167.  
  168.     val = xlargv[--i];
  169.  
  170.     /* do the work */
  171.     while (i-- > 0)
  172.         val = cons(xlargv[i],val);
  173.  
  174.     /* restore the stack */
  175.     xlpop();
  176.  
  177.     /* return the list */
  178.     return (val);
  179. }
  180.  
  181. /* xbutlast -- copy list for all but last n */
  182. /* Added function TAA */
  183.  
  184. LVAL xbutlast()
  185. {
  186.     LVAL val,list,last,next;
  187.     FIXTYPE n=1,l=0;
  188.  
  189.     /* get argument(s) */
  190.     list = xlgalist();
  191.     if (moreargs()) {
  192.         n = getfixnum(next=xlgafixnum());
  193.         if (n<0) xlerror("bad index",next);
  194.         xllastarg();
  195.     }
  196.  
  197.     /* get length */
  198.     for (next=list; consp(next);) {
  199.         next=cdr(next);
  200.         l++;
  201.         if (l > nnodes) xlcircular();
  202.     }
  203.  
  204.     /* calc final length */
  205.     l-=n;
  206.     if (l <= 0) return (NIL);   /* nothing left */
  207.  
  208.     /* do the first cons */
  209.  
  210.     val = consa(car(list));
  211.     if (l-- == 1) return val;
  212.  
  213.     /* protect a pointer */
  214.     xlprot1(val);
  215.  
  216.     /* do remaining conses */
  217.     last = val;
  218.     while (l-- > 0) {
  219.         list = cdr(list);
  220.         next = consa(car(list));
  221.         rplacd(last,next);
  222.         last = next;
  223.     }
  224.  
  225.  
  226.     /* restore the stack */
  227.     xlpop();
  228.  
  229.     /* return the list */
  230.     return (val);
  231. }
  232.  
  233.  
  234. /* xappend - built-in function append */
  235. LVAL xappend()
  236. {
  237.     LVAL list,last=NIL,next,val;
  238.  
  239.     /* protect some pointers */
  240.     xlsave1(val);
  241.  
  242.     /* append each argument */
  243.     if (moreargs()) {
  244.         while (xlargc > 1) {
  245.  
  246.             /* append each element of this list to the result list */
  247.             for (list = nextarg(); consp(list); list = cdr(list)) {
  248.                 next = consa(car(list));
  249.                 if (!null(val)) rplacd(last,next);
  250.                 else val = next;
  251.                 last = next;
  252.             }
  253.             if (!null(list)) xlbadtype(*--xlargv);  /*TAA added errormessage*/
  254.         }
  255.  
  256.         /* handle the last argument */
  257.         if (!null(val)) rplacd(last,nextarg());
  258.         else val = nextarg();
  259.     }
  260.  
  261.     /* restore the stack */
  262.     xlpop();
  263.  
  264.     /* return the list */
  265.     return (val);
  266. }
  267.  
  268.  
  269. /* xlast - return the last cons of a list */
  270. LVAL xlast()
  271. {
  272.     LVAL list;
  273.     long l=0;
  274.  
  275.     /* get the list */
  276.     list = xlgalist();
  277.     xllastarg();
  278.  
  279.     /* find the last cons */
  280.     if (consp(list))            /* TAA fix */
  281.         while (consp(cdr(list))) {
  282.             list = cdr(list);
  283.             if (l++ > nnodes) xlcircular();
  284.         }
  285.  
  286.     /* return the last element */
  287.     return (list);
  288. }
  289.  
  290. /* xmember - built-in function 'member' */
  291. LVAL xmember()
  292. {
  293.     LVAL x,list,fcn,val;
  294.     int tresult;
  295.     long n=0;
  296. #ifdef KEYARG
  297.     LVAL kfcn;
  298.  
  299.     /* protect some pointers */
  300.     xlstkcheck(2);
  301.     xlsave(fcn);
  302.     xlsave(kfcn);
  303. #else
  304.     /* protect some pointers */
  305.     xlsave1(fcn);
  306. #endif
  307.  
  308.     /* get the expression to look for and the list */
  309.     x = xlgetarg();
  310.     list = xlgalist();
  311.     xltest(&fcn,&tresult);
  312.  
  313. #ifdef KEYARG
  314.     kfcn = xlkey();
  315. #endif
  316.  
  317.     xllastarg();
  318.  
  319.     /* look for the expression */
  320.     for (val = NIL; consp(list); list = cdr(list)) {
  321. #ifdef KEYARG
  322.         if (dotest2(x,car(list),fcn,kfcn) == tresult)
  323. #else
  324.         if (dotest2(x,car(list),fcn) == tresult)
  325. #endif
  326.         {
  327.             val = list;
  328.             break;
  329.         }
  330.         if (n++ > nnodes) { val = NIL; break; } /* circular list */
  331.     }
  332.  
  333.     /* restore the stack */
  334. #ifdef KEYARG
  335.     xlpopn(2);
  336. #else
  337.     xlpop();
  338. #endif
  339.  
  340.     /* return the result */
  341.     return (val);
  342. }
  343.  
  344. /* xassoc - built-in function 'assoc' */
  345. LVAL xassoc()
  346. {
  347.     LVAL x,alist,fcn,pair,val;
  348.     int tresult;
  349.     long n=0;
  350. #ifdef KEYARG
  351.     LVAL kfcn;
  352.  
  353.     /* protect some pointers */
  354.     xlstkcheck(2);
  355.     xlsave(fcn);
  356.     xlsave(kfcn);
  357. #else
  358.     /* protect some pointers */
  359.     xlsave1(fcn);
  360. #endif
  361.  
  362.     /* get the expression to look for and the association list */
  363.     x = xlgetarg();
  364.     alist = xlgalist();
  365.     xltest(&fcn,&tresult);
  366.  
  367. #ifdef KEYARG
  368.     kfcn = xlkey();
  369. #endif
  370.  
  371.     xllastarg();
  372.  
  373.     /* look for the expression */
  374.     for (val = NIL; consp(alist); alist = cdr(alist)) {
  375.         if ((!null(pair = car(alist))) && consp(pair))
  376. #ifdef KEYARG
  377.             if (dotest2(x,car(pair),fcn,kfcn) == tresult)
  378. #else
  379.             if (dotest2(x,car(pair),fcn) == tresult)
  380. #endif
  381.             {
  382.                 val = pair;
  383.                 break;
  384.             }
  385.         if (n++ > nnodes) { val = NIL; break; } /* circular list */
  386.     }
  387.  
  388.     /* restore the stack */
  389. #ifdef KEYARG
  390.     xlpopn(2);
  391. #else
  392.     xlpop();
  393. #endif
  394.  
  395.     /* return result */
  396.     return (val);
  397. }
  398.  
  399. /* xsubst - substitute one expression for another */
  400. LVAL xsubst()
  401. {
  402.     LVAL to,from,expr,fcn,val;
  403.     int tresult;
  404. #ifdef KEYARG
  405.     LVAL kfcn;
  406.  
  407.     /* protect some pointers */
  408.     xlstkcheck(2);
  409.     xlsave(fcn);
  410.     xlsave(kfcn);
  411. #else
  412.     /* protect some pointers */
  413.     xlsave1(fcn);
  414. #endif
  415.  
  416.     /* get the to value, the from value and the expression */
  417.     to = xlgetarg();
  418.     from = xlgetarg();
  419.     expr = xlgetarg();
  420.     xltest(&fcn,&tresult);
  421.  
  422. #ifdef KEYARG
  423.     kfcn = xlkey();
  424. #endif
  425.  
  426.     xllastarg();
  427.  
  428.     /* do the substitution */
  429. #ifdef KEYARG
  430.     val = subst(to,from,expr,fcn,kfcn,tresult);
  431. #else
  432.     val = subst(to,from,expr,fcn,tresult);
  433. #endif
  434.  
  435.     /* restore the stack */
  436. #ifdef KEYARG
  437.     xlpopn(2);
  438. #else
  439.     xlpop();
  440. #endif
  441.  
  442.     /* return the result */
  443.     return (val);
  444. }
  445.  
  446. /* subst - substitute one expression for another */
  447. #ifdef KEYARG
  448. LOCAL LVAL XNEAR subst(to,from,expr,fcn,kfcn,tresult)
  449.   LVAL to,from,expr,fcn,kfcn; int tresult;
  450. #else
  451. LOCAL LVAL XNEAR subst(to,from,expr,fcn,tresult)
  452.   LVAL to,from,expr,fcn; int tresult;
  453. #endif
  454. {
  455.     LVAL carval,cdrval;
  456.  
  457. #ifdef KEYARG
  458.     if (dotest2(expr,from,fcn,kfcn) == tresult)
  459. #else
  460.     if (dotest2(expr,from,fcn) == tresult)
  461. #endif
  462.         return (to);
  463.     else if (consp(expr)) {
  464.         xlsave1(carval);
  465. #ifdef KEYARG
  466.         carval = subst(to,from,car(expr),fcn,kfcn,tresult);
  467.         cdrval = subst(to,from,cdr(expr),fcn,kfcn,tresult);
  468. #else
  469.         carval = subst(to,from,car(expr),fcn,tresult);
  470.         cdrval = subst(to,from,cdr(expr),fcn,tresult);
  471. #endif
  472.         xlpop();
  473.  
  474. /* the following TAA mod makes subst like COMMON LISP */
  475.  
  476.         if ((carval == car(expr)) && (cdrval == cdr(expr)))
  477.             return expr; /* no change */
  478.         else
  479.             return (cons(carval,cdrval));
  480.     }
  481.     else
  482.         return (expr);
  483. }
  484.  
  485. /* xsublis - substitute using an association list */
  486. LVAL xsublis()
  487. {
  488.     LVAL alist,expr,fcn,val;
  489.     int tresult;
  490. #ifdef KEYARG
  491.     LVAL kfcn;
  492.  
  493.     /* protect some pointers */
  494.     xlstkcheck(2);
  495.     xlsave(fcn);
  496.     xlsave(kfcn);
  497. #else
  498.     /* protect some pointers */
  499.     xlsave1(fcn);
  500. #endif
  501.  
  502.     /* get the assocation list and the expression */
  503.     alist = xlgalist();
  504.     expr = xlgetarg();
  505.     xltest(&fcn,&tresult);
  506.  
  507. #ifdef KEYARG
  508.     kfcn = xlkey();
  509. #endif
  510.  
  511.     xllastarg();
  512.  
  513.     /* do the substitution */
  514. #ifdef KEYARG
  515.     val = sublis(alist,expr,fcn,kfcn,tresult);
  516. #else
  517.     val = sublis(alist,expr,fcn,tresult);
  518. #endif
  519.  
  520.     /* restore the stack */
  521. #ifdef KEYARG
  522.     xlpopn(2);
  523. #else
  524.     xlpop();
  525. #endif
  526.  
  527.     /* return the result */
  528.     return (val);
  529. }
  530.  
  531. /* sublis - substitute using an association list */
  532. #ifdef KEYARG
  533. LOCAL LVAL XNEAR sublis(alist,expr,fcn,kfcn,tresult)
  534.   LVAL alist,expr,fcn,kfcn; int tresult;
  535. #else
  536. LOCAL LVAL XNEAR sublis(alist,expr,fcn,tresult)
  537.   LVAL alist,expr,fcn; int tresult;
  538. #endif
  539. {
  540.     LVAL carval,cdrval,pair;
  541.  
  542. #ifdef KEYARG
  543.     if (!null(pair = assoc(expr,alist,fcn,kfcn,tresult)))
  544. #else
  545.     if (!null(pair = assoc(expr,alist,fcn,tresult)))
  546. #endif
  547.         return (cdr(pair));
  548.     else if (consp(expr)) {
  549.         xlsave1(carval);
  550. #ifdef KEYARG
  551.         carval = sublis(alist,car(expr),fcn,kfcn,tresult);
  552.         cdrval = sublis(alist,cdr(expr),fcn,kfcn,tresult);
  553. #else
  554.         carval = sublis(alist,car(expr),fcn,tresult);
  555.         cdrval = sublis(alist,cdr(expr),fcn,tresult);
  556. #endif
  557.         xlpop();
  558. /* TAA MOD for making like common lisp */
  559.         if ((car(expr) == carval) && (cdr(expr) == cdrval))
  560.             return (expr);
  561.         else
  562.             return (cons(carval,cdrval));
  563.     }
  564.     else
  565.         return (expr);
  566. }
  567.  
  568. /* assoc - find a pair in an association list */
  569. #ifdef KEYARG
  570. LOCAL LVAL XNEAR assoc(expr,alist,fcn,kfcn,tresult)
  571.   LVAL expr,alist,fcn,kfcn; int tresult;
  572. #else
  573. LOCAL LVAL XNEAR assoc(expr,alist,fcn,tresult)
  574.   LVAL expr,alist,fcn; int tresult;
  575. #endif
  576. {
  577.     LVAL pair;
  578.  
  579.     for (; consp(alist); alist = cdr(alist))
  580.         if ((!null((pair = car(alist)))) && consp(pair))
  581. #ifdef KEYARG
  582.             if (dotest2(expr,car(pair),fcn,kfcn) == tresult)
  583. #else
  584.             if (dotest2(expr,car(pair),fcn) == tresult)
  585. #endif
  586.                 return (pair);
  587.     return (NIL);
  588. }
  589.  
  590. /* xnth - return the nth element of a list */
  591. LVAL xnth()
  592. {
  593.     return (nth(TRUE));
  594. }
  595.  
  596. /* xnthcdr - return the nth cdr of a list */
  597. LVAL xnthcdr()
  598. {
  599.     return (nth(FALSE));
  600. }
  601.  
  602. /* nth - internal nth function */
  603. LOCAL LVAL XNEAR nth(carflag)
  604.   int carflag;
  605. {
  606.     LVAL list,num;
  607.     FIXTYPE n;
  608.  
  609.     /* get n and the list */
  610.     num = xlgafixnum();
  611. /*  list = xlgacons(); */
  612.     list = xlgalist();      /* TAA fix */
  613.  
  614.     xllastarg();
  615.  
  616.     /* make sure the number isn't negative */
  617.     if ((n = getfixnum(num)) < 0)
  618.         xlfail("bad argument");
  619.  
  620.     /* find the nth element */
  621.     while (consp(list) && --n >= 0)
  622.         list = cdr(list);
  623.  
  624.     /* return the list beginning at the nth element */
  625.     return (carflag && consp(list) ? car(list) : list);
  626. }
  627.  
  628. /* xlength - return the length of a list or string */
  629. LVAL xlength()
  630. {
  631.     FIXTYPE n;
  632.     LVAL arg;
  633.  
  634.     /* get the list or string */
  635.     arg = xlgetarg();
  636.     xllastarg();
  637.  
  638.     /* find the length of a list */
  639.     if (listp(arg))
  640.         for (n = 0; consp(arg);) {
  641.             arg = cdr(arg);
  642.             n++;
  643.             if (n > nnodes) xlcircular();
  644.         }
  645.  
  646.     /* find the length of a string */
  647.     else if (stringp(arg))
  648.         n = (FIXTYPE)getslength(arg);
  649.  
  650.     /* find the length of a vector */
  651.     else if (vectorp(arg))
  652.         n = (FIXTYPE)getsize(arg);
  653.  
  654.     /* otherwise, bad argument type */
  655.     else
  656.                 xlbadtype(arg);
  657.  
  658.     /* return the length */
  659.     return (cvfixnum(n));
  660. }
  661.  
  662. /* map - internal mapping function */
  663. #define CONCAT 2    /* third choice for valflag */
  664.  
  665. #ifdef ANSI
  666. static LVAL XNEAR map(int carflag, int valflag)
  667. #else
  668. LOCAL LVAL XNEAR map(carflag,valflag)
  669.   int carflag,valflag;
  670. #endif
  671. {
  672.     FRAMEP newfp;
  673.     LVAL fun,lists,val,last,p,x,y;
  674.     int argc;
  675.     long n=0, nmax=nnodes;
  676.  
  677.  
  678.     /* protect some pointers */
  679.     xlstkcheck(3);
  680.     xlsave(fun);
  681.     xlsave(lists);
  682.     xlsave(val);
  683.  
  684.     /* get the function to apply and the first list */
  685.     fun = xlgetarg();
  686.     lists = xlgalist();
  687.  
  688.     /* initialize the result list */
  689.     val = (valflag ? NIL : lists);
  690.  
  691.     /* build a list of argument lists */
  692.     argc = 1;
  693.     for (lists = last = consa(lists); moreargs(); last = cdr(last)) {
  694.         argc++;
  695.         rplacd(last,cons(xlgalist(),NIL));
  696.     }
  697.  
  698.     /* loop through each of the argument lists */
  699.     for (;;) {
  700.  
  701.         if (n++ > nmax) xlcircular();
  702.  
  703.         /* build an argument list from the sublists */
  704.         newfp = xlsp;
  705.         pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  706.         pusharg(fun);
  707.         pusharg(cvfixnum((FIXTYPE)argc));
  708.         for (x = lists; (!null(x)) && (!null(y = car(x))) && consp(y); x = cdr(x)) {
  709.             pusharg(carflag ? car(y) : y);
  710.             rplaca(x,cdr(y));
  711.         }
  712.  
  713.         /* quit if any of the lists were empty */
  714.         if (!null(x)) {
  715.             xlsp = newfp;
  716.             break;
  717.         }
  718.  
  719.         /* apply the function to the arguments */
  720.         xlfp = newfp;
  721.         switch (valflag) {
  722.         case CONCAT:
  723.             p = xlapply(argc);
  724.             if (!null(p)) {
  725.                 if (!consp(p)) xlerror("non-list to concatenate", p);
  726.                 if (null(val)) val = p;
  727.                 else rplacd(last, p);
  728.                 while (consp(cdr(p))) p = cdr(p); /* find end--no circular check */
  729.                 last = p;
  730.             }
  731.             break;
  732.  
  733.         case TRUE:
  734.             p = consa(xlapply(argc));
  735.             if (!null(val)) rplacd(last,p);
  736.             else val = p;
  737.             last = p;
  738.             break;
  739.  
  740.         case FALSE:
  741.             xlapply(argc);
  742.             break;
  743.         }
  744.     }
  745.  
  746.     /* restore the stack */
  747.     xlpopn(3);
  748.  
  749.     /* return the last test expression value */
  750.     return (val);
  751. }
  752.  
  753. /* xmapc - built-in function 'mapc' */
  754. LVAL xmapc()
  755. {
  756.     return (map(TRUE,FALSE));
  757. }
  758.  
  759. /* xmapcar - built-in function 'mapcar' */
  760. LVAL xmapcar()
  761. {
  762.     return (map(TRUE,TRUE));
  763. }
  764.  
  765. /* xmapl - built-in function 'mapl' */
  766. LVAL xmapl()
  767. {
  768.     return (map(FALSE,FALSE));
  769. }
  770.  
  771. /* xmaplist - built-in function 'maplist' */
  772. LVAL xmaplist()
  773. {
  774.     return (map(FALSE,TRUE));
  775. }
  776.  
  777. /* xmapcan - built-in function 'mapcan' */
  778. LVAL xmapcan()
  779. {
  780.     return (map(TRUE,CONCAT));
  781. }
  782.  
  783. /* xmapcon - built-in function 'mapcon' */
  784. LVAL xmapcon()
  785. {
  786.     return (map(FALSE,CONCAT));
  787. }
  788.  
  789.  
  790.  
  791. /* xrplca - replace the car of a list node */
  792. LVAL xrplca()
  793. {
  794.     LVAL list,newcar;
  795.  
  796.     /* get the list and the new car */
  797.     list = xlgacons();
  798.     newcar = xlgetarg();
  799.     xllastarg();
  800.  
  801.     /* replace the car */
  802.     rplaca(list,newcar);
  803.  
  804.     /* return the list node that was modified */
  805.     return (list);
  806. }
  807.  
  808. /* xrplcd - replace the cdr of a list node */
  809. LVAL xrplcd()
  810. {
  811.     LVAL list,newcdr;
  812.  
  813.     /* get the list and the new cdr */
  814.     list = xlgacons();
  815.     newcdr = xlgetarg();
  816.     xllastarg();
  817.  
  818.     /* replace the cdr */
  819.     rplacd(list,newcdr);
  820.  
  821.     /* return the list node that was modified */
  822.     return (list);
  823. }
  824.  
  825. /* xnconc - destructively append lists */
  826. LVAL xnconc()
  827. {
  828.     LVAL next,last=NIL,val=NIL;
  829.     long l; /* TAA MOD */
  830.  
  831.     /* concatenate each argument */
  832.     if (moreargs()) {
  833.         while (xlargc > 1) {
  834.  
  835.             /* TAA mod -- give error message if not a list */
  836.             if ((!null(next = nextarg())) && consp(next)) {
  837.  
  838.                 /* concatenate this list to the result list */
  839.                 if (!null(val)) rplacd(last,next);
  840.                 else val = next;
  841.  
  842.                 /* find the end of the list */
  843.                 l = 0;
  844.                 while (consp(cdr(next))) {
  845.                     next = cdr(next);
  846.                     if (l++ > nnodes) xlcircular();
  847.                 }
  848.                 last = next;
  849.             }
  850.             else if (!null(next)) xlbadtype(*--xlargv); /* TAA -- oops! */
  851.         }
  852.  
  853.         /* handle the last argument */
  854.         if (!null(val)) rplacd(last,nextarg());
  855.         else val = nextarg();
  856.     }
  857.  
  858.     /* return the list */
  859.     return (val);
  860. }
  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.  
  870. /* gluelists - glue the smaller and larger lists with the pivot */
  871. #ifdef ANSI
  872. static LVAL XNEAR gluelists(LVAL smaller, LVAL pivot, LVAL larger)
  873. #else
  874. LOCAL LVAL gluelists(smaller,pivot,larger)
  875.   LVAL smaller,pivot,larger;
  876. #endif
  877. {
  878.     LVAL last;
  879.  
  880.     /* larger always goes after the pivot */
  881.     rplacd(pivot,larger);
  882.  
  883.     /* if the smaller list is empty, we're done */
  884.     if (null(smaller))
  885.         return (pivot);
  886.  
  887.     /* append the smaller to the front of the resulting list */
  888.     for (last = smaller; consp(cdr(last)); last = cdr(last))
  889.         ;
  890.     rplacd(last,pivot);
  891.     return (smaller);
  892. }
  893.  
  894. /* sortlist - sort a list using quicksort */
  895. #ifdef ANSI
  896. static LVAL XNEAR sortlist(LVAL list, LVAL fcn)
  897. #else
  898. LOCAL LVAL sortlist(list,fcn)
  899.   LVAL list,fcn;
  900. #endif
  901. {
  902.     LVAL smaller,pivot,larger;
  903.  
  904.     /* protect some pointers */
  905.     xlstkcheck(3)
  906.     xlsave(smaller);
  907.     xlsave(pivot);
  908.     xlsave(larger);
  909.  
  910.     /* lists with zero or one element are already sorted */
  911.     if (consp(list) && consp(cdr(list))) {
  912.         pivot = list; list = cdr(list);
  913.         splitlist(pivot,list,&smaller,&larger,fcn);
  914.         smaller = sortlist(smaller,fcn);
  915.         larger = sortlist(larger,fcn);
  916.         list = gluelists(smaller,pivot,larger);
  917.     }
  918.  
  919.     /* cleanup the stack and return the sorted list */
  920.     xlpopn(3);
  921.     return (list);
  922. }
  923.  
  924. /* splitlist - split the list around the pivot */
  925. LOCAL VOID XNEAR splitlist(pivot,list,psmaller,plarger,fcn)
  926.   LVAL pivot,list,*psmaller,*plarger,fcn;
  927. {
  928.     LVAL next;
  929. #ifdef KEYARG
  930.     LVAL tmp=car(pivot);
  931. #endif
  932.  
  933.     /* initialize the result lists */
  934.     *psmaller = *plarger = NIL;
  935.  
  936.     /* In case of garbage collection TAA Mod thanx to Neal Holtz */
  937. #ifdef KEYARG
  938.     xlstkcheck(3);
  939.     xlprotect(tmp);
  940. #else
  941.     xlstkcheck(2);
  942. #endif
  943.     xlprotect(list);
  944.     xlsave(next);
  945.  
  946. #ifdef KEYARG
  947.     if (!null(cdr(fcn))) tmp = xlapp1(cdr(fcn),tmp);
  948. #endif
  949.  
  950.     /* split the list */
  951.     for (; consp(list); list = next) {
  952.         next = cdr(list);
  953. #ifdef KEYARG
  954.         if (dotest2((!null(cdr(fcn)))?xlapp1(cdr(fcn),car(list)):car(list),
  955.             tmp,car(fcn),NIL) )
  956. #else
  957.         if (dotest2(car(list),car(pivot),fcn))
  958. #endif
  959.         {
  960.             rplacd(list,*psmaller);
  961.             *psmaller = list;
  962.         }
  963.         else {
  964.             rplacd(list,*plarger);
  965.             *plarger = list;
  966.         }
  967.     }
  968.  
  969.     /* restore the stack */
  970. #ifdef KEYARG
  971.     xlpopn(3);
  972. #else
  973.     xlpopn(2);
  974. #endif
  975. }
  976.  
  977. /* xsort - built-in function 'sort' */
  978. LVAL xsort()
  979. {
  980.     LVAL list,fcn;
  981.  
  982.     /* protect some pointers */
  983.     xlstkcheck(2);
  984.     xlsave(list);
  985.     xlsave(fcn);
  986.  
  987.     /* get the list to sort and the comparison function */
  988.     list = xlgalist();
  989. #ifdef KEYARG
  990.     fcn = cons(NIL,NIL);
  991.     rplaca(fcn,xlgetarg());
  992.     rplacd(fcn,xlkey());
  993. #else
  994.     fcn = xlgetarg();
  995. #endif
  996.     xllastarg();
  997.  
  998.     /* sort the list */
  999.     list = sortlist(list,fcn);
  1000.  
  1001.     /* restore the stack and return the sorted list */
  1002.     xlpopn(2);
  1003.     return (list);
  1004. }
  1005.  
  1006. #ifdef SETS
  1007. /* These functions have the following copyright notice: */
  1008. /* XLISP-STAT 2.0 Copyright (c) 1988, by Luke Tierney                  */
  1009. /*      All Rights Reserved                                            */
  1010. /*      Permission is granted for unrestricted non-commercial use      */
  1011.  
  1012. /* membr - internal MEMBER for set functions TAA */
  1013. #ifdef KEYARG
  1014. LOCAL LVAL XNEAR membr(expr,list,fcn,kfcn,tresult)
  1015.   LVAL expr,list,fcn,kfcn; int tresult;
  1016. {
  1017.     xlprot1(expr);
  1018.     if (!null(kfcn)) expr = xlapp1(kfcn,expr);
  1019.     for (; consp(list); list = cdr(list))
  1020.         if (dotest2(expr,car(list),fcn,kfcn) == tresult) {
  1021.             xlpop();
  1022.             return (list);
  1023.         }
  1024.     xlpop();
  1025.     return (NIL);
  1026. }
  1027.  
  1028. #else
  1029. LOCAL LVAL XNEAR membr(expr,list,fcn,tresult)
  1030.   LVAL expr,list,fcn; int tresult;
  1031. {
  1032.     for (; consp(list); list = cdr(list))
  1033.         if (dotest2(expr,car(list),fcn) == tresult)
  1034.                 return (list);
  1035.     return (NIL);
  1036. }
  1037. #endif
  1038.  
  1039. extern LVAL true;
  1040.  
  1041. /* Common Lisp ADJOIN function */
  1042. LVAL xadjoin()
  1043. {
  1044.     LVAL x, list, fcn;
  1045.     int tresult;
  1046. #ifdef KEYARG
  1047.     LVAL kfcn;
  1048.  
  1049.     /* protect some pointers */
  1050.     xlstkcheck(2);
  1051.     xlsave(fcn);
  1052.     xlsave(kfcn);
  1053. #else
  1054.     xlsave1(fcn);
  1055. #endif
  1056.  
  1057.     /* get the lists and key arguements, if any */
  1058.     x = xlgetarg();
  1059.     list = xlgalist();
  1060.     xltest(&fcn,&tresult);
  1061. #ifdef KEYARG
  1062.     kfcn = xlkey();
  1063. #endif
  1064.  
  1065.     xllastarg();
  1066.  
  1067. #ifdef KEYARG
  1068.     if (null(membr(x,list,fcn,kfcn,tresult))) list = cons(x,list) ;
  1069.     xlpopn(2);
  1070. #else
  1071.     if (null(membr(x,list,fcn,tresult))) list = cons(x,list) ;
  1072.     xlpop();
  1073. #endif
  1074.  
  1075.     return list;
  1076. }
  1077.  
  1078. #ifdef ANSI
  1079. static LVAL XNEAR set_op(int which)
  1080. #else
  1081. LOCAL LVAL set_op(which)
  1082.         int which;
  1083. #endif
  1084. {
  1085.     LVAL x, list1, list2, result, fcn;
  1086.     int tresult;
  1087. #ifdef KEYARG
  1088.     LVAL kfcn;
  1089.  
  1090.     /* protect some pointers */
  1091.     xlstkcheck(3);
  1092.     xlsave(kfcn);
  1093. #else
  1094.  
  1095.     /* protect some pointers */
  1096.     xlstkcheck(2);
  1097. #endif
  1098.     xlsave(fcn);
  1099.     xlsave(result);
  1100.  
  1101.     /* get the lists and key arguements, if any */
  1102.     list1 = xlgalist();
  1103.     list2 = xlgalist();
  1104.     xltest(&fcn,&tresult);
  1105. #ifdef KEYARG
  1106.     kfcn = xlkey();
  1107. #endif
  1108.  
  1109.     xllastarg();
  1110.  
  1111.     switch(which) {
  1112.         case 'U':
  1113.             for (result = list1; consp(list2); list2 = cdr(list2)) {
  1114.                 x = car(list2);
  1115. #ifdef KEYARG
  1116.                 if (null(membr(x,list1,fcn,kfcn,tresult)))
  1117. #else
  1118.                 if (null(membr(x,list1,fcn,tresult)))
  1119. #endif
  1120.                     result = cons(x, result);
  1121.             }
  1122.             break;
  1123.         case 'I':
  1124.             for (result = NIL; consp(list2); list2 = cdr(list2)) {
  1125.                 x = car(list2);
  1126. #ifdef KEYARG
  1127.                 if (!null(membr(x,list1,fcn,kfcn,tresult)))
  1128. #else
  1129.                 if (!null(membr(x,list1,fcn,tresult)))
  1130. #endif
  1131.                     result = cons(x, result);
  1132.             }
  1133.             break;
  1134.         case 'D':
  1135.             for (result = NIL; consp(list1); list1 = cdr(list1)) {
  1136.                 x = car(list1);
  1137. #ifdef KEYARG
  1138.                 if (null(membr(x,list2,fcn,kfcn,tresult)))
  1139. #else
  1140.                 if (null(membr(x,list2,fcn,tresult)))
  1141. #endif
  1142.                     result = cons(x, result);
  1143.             }
  1144.             break;
  1145.         case 'S':
  1146.             for (result = true; consp(list1); list1 = cdr(list1)) {
  1147.                 x = car(list1);
  1148. #ifdef KEYARG
  1149.                 if (null(membr(x,list2,fcn,kfcn,tresult)))
  1150. #else
  1151.                 if (null(membr(x,list2,fcn,tresult)))
  1152. #endif
  1153.                 {
  1154.                     result = NIL;
  1155.                     break;
  1156.                 }
  1157.             }
  1158.             break;
  1159.     }
  1160.  
  1161. #ifdef KEYARG
  1162.     xlpopn(3);
  1163. #else
  1164.     xlpopn(2);
  1165. #endif
  1166.     return(result);
  1167. }
  1168.  
  1169. LVAL xunion()          { return(set_op('U')); }
  1170. LVAL xintersection()   { return(set_op('I')); }
  1171. LVAL xset_difference() { return(set_op('D')); }
  1172. LVAL xsubsetp()        { return(set_op('S')); }
  1173.  
  1174. #endif
  1175.  
  1176.  
  1177. /* HASH TABLES ARE IMPLEMENTED AS STRUCTS, WITHOUT ACCESSING FCNS */
  1178.  
  1179. #ifdef HASHFCNS
  1180. extern LVAL a_hashtable, k_size, k_test, s_eql;
  1181.  
  1182. /* Hash table functions from Ken Whedbee */
  1183. LVAL xmakehash()    /* rewritten by TAA */
  1184. {
  1185.     LVAL size, testfcn, result;
  1186.     FIXTYPE len;
  1187.  
  1188.     if (xlgetkeyarg(k_size,&size)) {
  1189.         if (!fixp(size) || (len=getfixnum(size)) < 1) xlbadtype(size);
  1190.     }
  1191.     else len = 31;
  1192.  
  1193.     if (!xlgetkeyarg(k_test,&testfcn)) testfcn = getfunction(s_eql);
  1194.  
  1195.     xllastarg();
  1196.  
  1197.     xlprot1(testfcn);
  1198.  
  1199.     result = newstruct(a_hashtable,(int)len+1);
  1200.  
  1201.     setelement(result, 1, testfcn);
  1202.  
  1203.     xlpop();
  1204.  
  1205.     return result;
  1206. }
  1207.  
  1208. LVAL xgethash()
  1209. {
  1210.     LVAL alist,val,key,table,def=NIL;
  1211.  
  1212.     key = xlgetarg();
  1213.     table = xlgastruct();
  1214.     if (moreargs()) {
  1215.         def = xlgetarg();
  1216.         xllastarg();
  1217.     }
  1218.     if (getelement(table, 0) != a_hashtable)
  1219.         xlbadtype(table);
  1220.  
  1221.     alist = getelement(table,
  1222.         xlhash(key,getsize(table)-2) + 2);
  1223.  
  1224. #ifdef KEYARG
  1225.     val = assoc(key,alist,getelement(table,1),NIL,TRUE);
  1226. #else
  1227.     val = assoc(key,alist,getelement(table,1),TRUE);
  1228. #endif
  1229.  
  1230.     /* return result */
  1231.     return (null(val) ? def : cdr(val));
  1232. }
  1233.  
  1234. LVAL xremhash()
  1235. /* By TAA -- can't use assoc here*/
  1236. {
  1237.     LVAL alist,key,table,last;
  1238.  
  1239.     int idx;
  1240.  
  1241.     key = xlgetarg();
  1242.     table = xlgastruct();
  1243.     xllastarg();
  1244.  
  1245.     if (getelement(table, 0) != a_hashtable)
  1246.         xlbadtype(table);
  1247.  
  1248.     idx = xlhash(key,getsize(table)-2) + 2;
  1249.  
  1250.     alist = getelement(table,idx);
  1251.  
  1252.     if (null(alist))
  1253.         return NIL;
  1254.  
  1255. #ifdef KEYARG
  1256.     else if (dotest2(key,car(car(alist)),getelement(table,1),NIL)==TRUE)
  1257. #else
  1258.     else if (dotest2(key,car(car(alist)),getelement(table,1))==TRUE)
  1259. #endif
  1260.         {
  1261.         setelement(table,idx,cdr(alist));   /* matches first element */
  1262.         return true;
  1263.     }
  1264.     else {
  1265.         last = alist;
  1266.         alist = cdr(alist);
  1267.         while (consp(alist)) {
  1268. #ifdef KEYARG
  1269.             if (dotest2(key,car(car(alist)),getelement(table,1),NIL)==TRUE)
  1270. #else
  1271.             if (dotest2(key,car(car(alist)),getelement(table,1))==TRUE)
  1272. #endif
  1273.             {
  1274.                 rplacd(last,cdr(alist));
  1275.                 return true;
  1276.             }
  1277.             last = alist;
  1278.             alist = cdr(alist);
  1279.         }
  1280.     }
  1281.  
  1282.     return NIL;
  1283. }
  1284.  
  1285. VOID xlsetgethash(key,table,value)
  1286. LVAL key,table,value;
  1287. {
  1288.     LVAL alist,oldval;
  1289.     int idx;
  1290.  
  1291.     if (getelement(table, 0) != a_hashtable)
  1292.         xlbadtype(table);
  1293.  
  1294.     idx = xlhash(key,getsize(table)-2) + 2;
  1295.  
  1296.     alist = getelement(table,idx);
  1297.  
  1298. #ifdef KEYARG
  1299.     if (!null(oldval = assoc(key,alist,getelement(table,1),NIL,TRUE)))
  1300. #else
  1301.     if (!null(oldval = assoc(key,alist,getelement(table,1),TRUE)))
  1302. #endif
  1303.         rplacd(oldval,value);
  1304.     else {
  1305.         alist = cons(cons(key,value),alist);
  1306.         setelement(table,idx,alist);
  1307.     }
  1308. }
  1309.  
  1310. /* function clrhash  TAA */
  1311.  
  1312. LVAL xclrhash()
  1313. {
  1314.     LVAL table;
  1315.     int i;
  1316.  
  1317.     table = xlgastruct();
  1318.     xllastarg();
  1319.  
  1320.     if (getelement(table, 0) != a_hashtable)
  1321.         xlbadtype(table);
  1322.  
  1323.     for (i = getsize(table)-1; i > 1; i--) setelement(table,i,NIL);
  1324.  
  1325.     return (table);
  1326.  
  1327. }
  1328.  
  1329. /* function hash-table-count  TAA */
  1330.  
  1331. LVAL xhashcount()
  1332. {
  1333.     LVAL table, element;
  1334.     int i;
  1335.     FIXTYPE cnt = 0;
  1336.  
  1337.     table = xlgastruct();
  1338.     xllastarg();
  1339.  
  1340.     if (getelement(table, 0) != a_hashtable)
  1341.         xlbadtype(table);
  1342.  
  1343.     for (i = getsize(table)-1; i > 1; i--)
  1344.         for (element=getelement(table,i);consp(element);element=cdr(element))
  1345.             cnt++;
  1346.  
  1347.     return (cvfixnum(cnt));
  1348. }
  1349.  
  1350. /* function maphash  TAA */
  1351.  
  1352. LVAL xmaphash()
  1353. {
  1354.     FRAMEP newfp;
  1355.     LVAL fun, table, arg, element;
  1356.     int i;
  1357.  
  1358.     fun = xlgetarg();
  1359.     table = xlgastruct();
  1360.     xllastarg();
  1361.  
  1362.     if (getelement(table, 0) != a_hashtable)
  1363.         xlbadtype(table);
  1364.  
  1365.     xlstkcheck(2);
  1366.     xlprotect(fun);
  1367.     xlprotect(table);
  1368.  
  1369.     for (i = getsize(table)-1; i > 1; i--)
  1370.         for (element=getelement(table,i); consp(element);) {
  1371.             arg = car(element);
  1372.             element = cdr(element); /* in case element is deleted */
  1373.             newfp =xlsp;
  1374.             pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  1375.             pusharg(fun);
  1376.             pusharg(cvfixnum((FIXTYPE) 2));
  1377.             pusharg(car(arg));
  1378.             pusharg(cdr(arg));
  1379.             xlfp = newfp;
  1380.             xlapply(2);
  1381.         }
  1382.  
  1383.     xlpopn(2);
  1384.  
  1385.     return (NIL);
  1386. }
  1387.  
  1388. #endif
  1389.