home *** CD-ROM | disk | FTP | other *** search
/ The C Users' Group Library 1994 August / wc-cdrom-cusersgrouplibrary-1994-08.iso / vol_100 / 176_01 / xllist.c < prev    next >
Text File  |  1985-12-21  |  19KB  |  838 lines
  1. /* xllist - 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. #ifdef MEGAMAX
  9. overlay "overflow"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE ***xlstack;
  14. extern NODE *s_unbound;
  15. extern NODE *true;
  16.  
  17. /* external routines */
  18. extern int eq(),eql(),equal();
  19.  
  20. /* forward declarations */
  21. FORWARD NODE *cxr();
  22. FORWARD NODE *nth(),*assoc();
  23. FORWARD NODE *subst(),*sublis(),*map();
  24. FORWARD NODE *cequal();
  25.  
  26. /* cxr functions */
  27. NODE *xcar(args) NODE *args; { return (cxr(args,"a")); }
  28. NODE *xcdr(args) NODE *args; { return (cxr(args,"d")); }
  29.  
  30. /* cxxr functions */
  31. NODE *xcaar(args) NODE *args; { return (cxr(args,"aa")); }
  32. NODE *xcadr(args) NODE *args; { return (cxr(args,"da")); }
  33. NODE *xcdar(args) NODE *args; { return (cxr(args,"ad")); }
  34. NODE *xcddr(args) NODE *args; { return (cxr(args,"dd")); }
  35.  
  36. /* cxxxr functions */
  37. NODE *xcaaar(args) NODE *args; { return (cxr(args,"aaa")); }
  38. NODE *xcaadr(args) NODE *args; { return (cxr(args,"daa")); }
  39. NODE *xcadar(args) NODE *args; { return (cxr(args,"ada")); }
  40. NODE *xcaddr(args) NODE *args; { return (cxr(args,"dda")); }
  41. NODE *xcdaar(args) NODE *args; { return (cxr(args,"aad")); }
  42. NODE *xcdadr(args) NODE *args; { return (cxr(args,"dad")); }
  43. NODE *xcddar(args) NODE *args; { return (cxr(args,"add")); }
  44. NODE *xcdddr(args) NODE *args; { return (cxr(args,"ddd")); }
  45.  
  46. /* cxxxxr functions */
  47. NODE *xcaaaar(args) NODE *args; { return (cxr(args,"aaaa")); }
  48. NODE *xcaaadr(args) NODE *args; { return (cxr(args,"daaa")); }
  49. NODE *xcaadar(args) NODE *args; { return (cxr(args,"adaa")); }
  50. NODE *xcaaddr(args) NODE *args; { return (cxr(args,"ddaa")); }
  51. NODE *xcadaar(args) NODE *args; { return (cxr(args,"aada")); }
  52. NODE *xcadadr(args) NODE *args; { return (cxr(args,"dada")); }
  53. NODE *xcaddar(args) NODE *args; { return (cxr(args,"adda")); }
  54. NODE *xcadddr(args) NODE *args; { return (cxr(args,"ddda")); }
  55. NODE *xcdaaar(args) NODE *args; { return (cxr(args,"aaad")); }
  56. NODE *xcdaadr(args) NODE *args; { return (cxr(args,"daad")); }
  57. NODE *xcdadar(args) NODE *args; { return (cxr(args,"adad")); }
  58. NODE *xcdaddr(args) NODE *args; { return (cxr(args,"ddad")); }
  59. NODE *xcddaar(args) NODE *args; { return (cxr(args,"aadd")); }
  60. NODE *xcddadr(args) NODE *args; { return (cxr(args,"dadd")); }
  61. NODE *xcdddar(args) NODE *args; { return (cxr(args,"addd")); }
  62. NODE *xcddddr(args) NODE *args; { return (cxr(args,"dddd")); }
  63.  
  64. /* cxr - common car/cdr routine */
  65. LOCAL NODE *cxr(args,adstr)
  66.   NODE *args; char *adstr;
  67. {
  68.     NODE *list;
  69.  
  70.     /* get the list */
  71.     list = xlmatch(LIST,&args);
  72.     xllastarg(args);
  73.  
  74.     /* perform the car/cdr operations */
  75.     while (*adstr && consp(list))
  76.     list = (*adstr++ == 'a' ? car(list) : cdr(list));
  77.  
  78.     /* make sure the operation succeeded */
  79.     if (*adstr && list)
  80.     xlfail("bad argument");
  81.  
  82.     /* return the result */
  83.     return (list);
  84. }
  85.  
  86. /* xcons - construct a new list cell */
  87. NODE *xcons(args)
  88.   NODE *args;
  89. {
  90.     NODE *arg1,*arg2;
  91.  
  92.     /* get the two arguments */
  93.     arg1 = xlarg(&args);
  94.     arg2 = xlarg(&args);
  95.     xllastarg(args);
  96.  
  97.     /* construct a new list element */
  98.     return (cons(arg1,arg2));
  99. }
  100.  
  101. /* xlist - built a list of the arguments */
  102. NODE *xlist(args)
  103.   NODE *args;
  104. {
  105.     NODE ***oldstk,*arg,*list,*val,*last,*lptr;
  106.  
  107.     /* create a new stack frame */
  108.     oldstk = xlsave(&arg,&list,&val,NULL);
  109.  
  110.     /* initialize */
  111.     arg = args;
  112.  
  113.     /* evaluate and append each argument */
  114.     for (last = NIL; arg; last = lptr) {
  115.  
  116.     /* evaluate the next argument */
  117.     val = xlarg(&arg);
  118.  
  119.     /* append this argument to the end of the list */
  120.     lptr = consa(val);
  121.     if (last == NIL)
  122.         list = lptr;
  123.     else
  124.         rplacd(last,lptr);
  125.     }
  126.  
  127.     /* restore the previous stack frame */
  128.     xlstack = oldstk;
  129.  
  130.     /* return the list */
  131.     return (list);
  132. }
  133.  
  134. /* xappend - built-in function append */
  135. NODE *xappend(args)
  136.   NODE *args;
  137. {
  138.     NODE ***oldstk,*arg,*list,*last,*val,*lptr;
  139.  
  140.     /* create a new stack frame */
  141.     oldstk = xlsave(&arg,&list,&last,&val,NULL);
  142.  
  143.     /* initialize */
  144.     arg = args;
  145.  
  146.     /* evaluate and append each argument */
  147.     while (arg) {
  148.  
  149.     /* evaluate the next argument */
  150.     list = xlmatch(LIST,&arg);
  151.  
  152.     /* append each element of this list to the result list */
  153.     while (consp(list)) {
  154.  
  155.         /* append this element */
  156.         lptr = consa(car(list));
  157.         if (last == NIL)
  158.         val = lptr;
  159.         else
  160.         rplacd(last,lptr);
  161.  
  162.         /* save the new last element */
  163.         last = lptr;
  164.  
  165.         /* move to the next element */
  166.         list = cdr(list);
  167.     }
  168.     }
  169.  
  170.     /* restore previous stack frame */
  171.     xlstack = oldstk;
  172.  
  173.     /* return the list */
  174.     return (val);
  175. }
  176.  
  177. /* xreverse - built-in function reverse */
  178. NODE *xreverse(args)
  179.   NODE *args;
  180. {
  181.     NODE ***oldstk,*list,*val;
  182.  
  183.     /* create a new stack frame */
  184.     oldstk = xlsave(&list,&val,NULL);
  185.  
  186.     /* get the list to reverse */
  187.     list = xlmatch(LIST,&args);
  188.     xllastarg(args);
  189.  
  190.     /* append each element of this list to the result list */
  191.     while (consp(list)) {
  192.  
  193.     /* append this element */
  194.     val = cons(car(list),val);
  195.  
  196.     /* move to the next element */
  197.     list = cdr(list);
  198.     }
  199.  
  200.     /* restore previous stack frame */
  201.     xlstack = oldstk;
  202.  
  203.     /* return the list */
  204.     return (val);
  205. }
  206.  
  207. /* xlast - return the last cons of a list */
  208. NODE *xlast(args)
  209.   NODE *args;
  210. {
  211.     NODE *list;
  212.  
  213.     /* get the list */
  214.     list = xlmatch(LIST,&args);
  215.     xllastarg(args);
  216.  
  217.     /* find the last cons */
  218.     while (consp(list) && cdr(list))
  219.     list = cdr(list);
  220.  
  221.     /* return the last element */
  222.     return (list);
  223. }
  224.  
  225. /* xmember - built-in function 'member' */
  226. NODE *xmember(args)
  227.   NODE *args;
  228. {
  229.     NODE ***oldstk,*x,*list,*fcn,*val;
  230.     int tresult;
  231.  
  232.     /* create a new stack frame */
  233.     oldstk = xlsave(&x,&list,&fcn,NULL);
  234.  
  235.     /* get the expression to look for and the list */
  236.     x = xlarg(&args);
  237.     list = xlmatch(LIST,&args);
  238.     xltest(&fcn,&tresult,&args);
  239.     xllastarg(args);
  240.  
  241.     /* look for the expression */
  242.     for (val = NIL; consp(list); list = cdr(list))
  243.     if (dotest(x,car(list),fcn) == tresult) {
  244.         val = list;
  245.         break;
  246.     }
  247.  
  248.     /* restore the previous stack frame */
  249.     xlstack = oldstk;
  250.  
  251.     /* return the result */
  252.     return (val);
  253. }
  254.  
  255. /* xassoc - built-in function 'assoc' */
  256. NODE *xassoc(args)
  257.   NODE *args;
  258. {
  259.     NODE ***oldstk,*x,*alist,*fcn,*pair,*val;
  260.     int tresult;
  261.  
  262.     /* create a new stack frame */
  263.     oldstk = xlsave(&x,&alist,&fcn,NULL);
  264.  
  265.     /* get the expression to look for and the association list */
  266.     x = xlarg(&args);
  267.     alist = xlmatch(LIST,&args);
  268.     xltest(&fcn,&tresult,&args);
  269.     xllastarg(args);
  270.  
  271.     /* look for the expression */
  272.     for (val = NIL; consp(alist); alist = cdr(alist))
  273.     if ((pair = car(alist)) && consp(pair))
  274.         if (dotest(x,car(pair),fcn) == tresult) {
  275.         val = pair;
  276.         break;
  277.         }
  278.  
  279.     /* restore the previous stack frame */
  280.     xlstack = oldstk;
  281.  
  282.     /* return the result */
  283.     return (val);
  284. }
  285.  
  286. /* xsubst - substitute one expression for another */
  287. NODE *xsubst(args)
  288.   NODE *args;
  289. {
  290.     NODE ***oldstk,*to,*from,*expr,*fcn,*val;
  291.     int tresult;
  292.  
  293.     /* create a new stack frame */
  294.     oldstk = xlsave(&to,&from,&expr,&fcn,NULL);
  295.  
  296.     /* get the to value, the from value and the expression */
  297.     to = xlarg(&args);
  298.     from = xlarg(&args);
  299.     expr = xlarg(&args);
  300.     xltest(&fcn,&tresult,&args);
  301.     xllastarg(args);
  302.  
  303.     /* do the substitution */
  304.     val = subst(to,from,expr,fcn,tresult);
  305.  
  306.     /* restore the previous stack frame */
  307.     xlstack = oldstk;
  308.  
  309.     /* return the result */
  310.     return (val);
  311. }
  312.  
  313. /* subst - substitute one expression for another */
  314. LOCAL NODE *subst(to,from,expr,fcn,tresult)
  315.   NODE *to,*from,*expr,*fcn; int tresult;
  316. {
  317.     NODE ***oldstk,*carval,*cdrval,*val;
  318.  
  319.     if (dotest(expr,from,fcn) == tresult)
  320.     val = to;
  321.     else if (consp(expr)) {
  322.     oldstk = xlsave(&carval,&cdrval,NULL);
  323.     carval = subst(to,from,car(expr),fcn,tresult);
  324.     cdrval = subst(to,from,cdr(expr),fcn,tresult);
  325.     val = cons(carval,cdrval);
  326.     xlstack = oldstk;
  327.     }
  328.     else
  329.     val = expr;
  330.     return (val);
  331. }
  332.  
  333. /* xsublis - substitute using an association list */
  334. NODE *xsublis(args)
  335.   NODE *args;
  336. {
  337.     NODE ***oldstk,*alist,*expr,*fcn,*val;
  338.     int tresult;
  339.  
  340.     /* create a new stack frame */
  341.     oldstk = xlsave(&alist,&expr,&fcn,NULL);
  342.  
  343.     /* get the assocation list and the expression */
  344.     alist = xlmatch(LIST,&args);
  345.     expr = xlarg(&args);
  346.     xltest(&fcn,&tresult,&args);
  347.     xllastarg(args);
  348.  
  349.     /* do the substitution */
  350.     val = sublis(alist,expr,fcn,tresult);
  351.  
  352.     /* restore the previous stack frame */
  353.     xlstack = oldstk;
  354.  
  355.     /* return the result */
  356.     return (val);
  357. }
  358.  
  359. /* sublis - substitute using an association list */
  360. LOCAL NODE *sublis(alist,expr,fcn,tresult)
  361.   NODE *alist,*expr,*fcn; int tresult;
  362. {
  363.     NODE ***oldstk,*carval,*cdrval,*val;
  364.  
  365.     if (val = assoc(expr,alist,fcn,tresult))
  366.     val = cdr(val);
  367.     else if (consp(expr)) {
  368.     oldstk = xlsave(&carval,&cdrval,NULL);
  369.     carval = sublis(alist,car(expr),fcn,tresult);
  370.     cdrval = sublis(alist,cdr(expr),fcn,tresult);
  371.     val = cons(carval,cdrval);
  372.     xlstack = oldstk;
  373.     }
  374.     else
  375.     val = expr;
  376.     return (val);
  377. }
  378.  
  379. /* assoc - find a pair in an association list */
  380. LOCAL NODE *assoc(expr,alist,fcn,tresult)
  381.   NODE *expr,*alist,*fcn; int tresult;
  382. {
  383.     NODE *pair;
  384.  
  385.     for (; consp(alist); alist = cdr(alist))
  386.     if ((pair = car(alist)) && consp(pair))
  387.         if (dotest(expr,car(pair),fcn) == tresult)
  388.         return (pair);
  389.     return (NIL);
  390. }
  391.  
  392. /* xremove - built-in function 'remove' */
  393. NODE *xremove(args)
  394.   NODE *args;
  395. {
  396.     NODE ***oldstk,*x,*list,*fcn,*val,*p,*last;
  397.     int tresult;
  398.  
  399.     /* create a new stack frame */
  400.     oldstk = xlsave(&x,&list,&fcn,&val,NULL);
  401.  
  402.     /* get the expression to remove and the list */
  403.     x = xlarg(&args);
  404.     list = xlmatch(LIST,&args);
  405.     xltest(&fcn,&tresult,&args);
  406.     xllastarg(args);
  407.  
  408.     /* remove matches */
  409.     while (consp(list)) {
  410.  
  411.     /* check to see if this element should be deleted */
  412.     if (dotest(x,car(list),fcn) != tresult) {
  413.         p = consa(car(list));
  414.         if (val) rplacd(last,p);
  415.         else val = p;
  416.         last = p;
  417.     }
  418.  
  419.     /* move to the next element */
  420.     list = cdr(list);
  421.     }
  422.  
  423.     /* restore the previous stack frame */
  424.     xlstack = oldstk;
  425.  
  426.     /* return the updated list */
  427.     return (val);
  428. }
  429.  
  430. /* dotest - call a test function */
  431. int dotest(arg1,arg2,fcn)
  432.   NODE *arg1,*arg2,*fcn;
  433. {
  434.     NODE ***oldstk,*args,*val;
  435.  
  436.     /* create a new stack frame */
  437.     oldstk = xlsave(&args,NULL);
  438.  
  439.     /* build an argument list */
  440.     args = consa(arg1);
  441.     rplacd(args,consa(arg2));
  442.  
  443.     /* apply the test function */
  444.     val = xlapply(fcn,args);
  445.  
  446.     /* restore the previous stack frame */
  447.     xlstack = oldstk;
  448.  
  449.     /* return the result of the test */
  450.     return (val != NIL);
  451. }
  452.  
  453. /* xnth - return the nth element of a list */
  454. NODE *xnth(args)
  455.   NODE *args;
  456. {
  457.     return (nth(args,TRUE));
  458. }
  459.  
  460. /* xnthcdr - return the nth cdr of a list */
  461. NODE *xnthcdr(args)
  462.   NODE *args;
  463. {
  464.     return (nth(args,FALSE));
  465. }
  466.  
  467. /* nth - internal nth function */
  468. LOCAL NODE *nth(args,carflag)
  469.   NODE *args; int carflag;
  470. {
  471.     NODE *list;
  472.     int n;
  473.  
  474.     /* get n and the list */
  475.     if ((n = getfixnum(xlmatch(INT,&args))) < 0)
  476.     xlfail("bad argument");
  477.     if ((list = xlmatch(LIST,&args)) == NIL)
  478.     xlfail("bad argument");
  479.     xllastarg(args);
  480.  
  481.     /* find the nth element */
  482.     while (consp(list) && n--)
  483.     list = cdr(list);
  484.  
  485.     /* return the list beginning at the nth element */
  486.     return (carflag && consp(list) ? car(list) : list);
  487. }
  488.  
  489. /* xlength - return the length of a list or string */
  490. NODE *xlength(args)
  491.   NODE *args;
  492. {
  493.     NODE *arg;
  494.     int n;
  495.  
  496.     /* get the list or string */
  497.     arg = xlarg(&args);
  498.     xllastarg(args);
  499.  
  500.     /* find the length of a list */
  501.     if (listp(arg))
  502.     for (n = 0; consp(arg); n++)
  503.         arg = cdr(arg);
  504.  
  505.     /* find the length of a string */
  506.     else if (stringp(arg))
  507.     n = strlen(getstring(arg));
  508.  
  509.     /* find the length of a vector */
  510.     else if (vectorp(arg))
  511.     n = getsize(arg);
  512.  
  513.     /* otherwise, bad argument type */
  514.     else
  515.     xlerror("bad argument type",arg);
  516.  
  517.     /* return the length */
  518.     return (cvfixnum((FIXNUM)n));
  519. }
  520.  
  521. /* xmapc - built-in function 'mapc' */
  522. NODE *xmapc(args)
  523.   NODE *args;
  524. {
  525.     return (map(args,TRUE,FALSE));
  526. }
  527.  
  528. /* xmapcar - built-in function 'mapcar' */
  529. NODE *xmapcar(args)
  530.   NODE *args;
  531. {
  532.     return (map(args,TRUE,TRUE));
  533. }
  534.  
  535. /* xmapl - built-in function 'mapl' */
  536. NODE *xmapl(args)
  537.   NODE *args;
  538. {
  539.     return (map(args,FALSE,FALSE));
  540. }
  541.  
  542. /* xmaplist - built-in function 'maplist' */
  543. NODE *xmaplist(args)
  544.   NODE *args;
  545. {
  546.     return (map(args,FALSE,TRUE));
  547. }
  548.  
  549. /* map - internal mapping function */
  550. LOCAL NODE *map(args,carflag,valflag)
  551.   NODE *args; int carflag,valflag;
  552. {
  553.     NODE ***oldstk,*fcn,*lists,*arglist,*val,*last,*p,*x,*y;
  554.  
  555.     /* create a new stack frame */
  556.     oldstk = xlsave(&fcn,&lists,&arglist,&val,NULL);
  557.  
  558.     /* get the function to apply and the first list */
  559.     fcn = xlarg(&args);
  560.     lists = xlmatch(LIST,&args);
  561.  
  562.     /* save the first list if not saving function values */
  563.     if (!valflag)
  564.     val = lists;
  565.  
  566.     /* set up the list of argument lists */
  567.     lists = consa(lists);
  568.  
  569.     /* get the remaining argument lists */
  570.     while (args) {
  571.     lists = consd(lists);
  572.     rplaca(lists,xlmatch(LIST,&args));
  573.     }
  574.  
  575.     /* if the function is a symbol, get its value */
  576.     if (symbolp(fcn))
  577.     fcn = xleval(fcn);
  578.  
  579.     /* loop through each of the argument lists */
  580.     for (;;) {
  581.  
  582.     /* build an argument list from the sublists */
  583.     arglist = NIL;
  584.     for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
  585.         arglist = consd(arglist);
  586.         rplaca(arglist,carflag ? car(y) : y);
  587.         rplaca(x,cdr(y));
  588.     }
  589.  
  590.     /* quit if any of the lists were empty */
  591.     if (x) break;
  592.  
  593.     /* apply the function to the arguments */
  594.     if (valflag) {
  595.         p = consa(NIL);
  596.         if (val) rplacd(last,p);
  597.         else val = p;
  598.         rplaca(p,xlapply(fcn,arglist));
  599.         last = p;
  600.     }
  601.     else
  602.         xlapply(fcn,arglist);
  603.     }
  604.  
  605.     /* restore the previous stack frame */
  606.     xlstack = oldstk;
  607.  
  608.     /* return the last test expression value */
  609.     return (val);
  610. }
  611.  
  612. /* xrplca - replace the car of a list node */
  613. NODE *xrplca(args)
  614.   NODE *args;
  615. {
  616.     NODE *list,*newcar;
  617.  
  618.     /* get the list and the new car */
  619.     if ((list = xlmatch(LIST,&args)) == NIL)
  620.     xlfail("bad argument");
  621.     newcar = xlarg(&args);
  622.     xllastarg(args);
  623.  
  624.     /* replace the car */
  625.     rplaca(list,newcar);
  626.  
  627.     /* return the list node that was modified */
  628.     return (list);
  629. }
  630.  
  631. /* xrplcd - replace the cdr of a list node */
  632. NODE *xrplcd(args)
  633.   NODE *args;
  634. {
  635.     NODE *list,*newcdr;
  636.  
  637.     /* get the list and the new cdr */
  638.     if ((list = xlmatch(LIST,&args)) == NIL)
  639.     xlfail("bad argument");
  640.     newcdr = xlarg(&args);
  641.     xllastarg(args);
  642.  
  643.     /* replace the cdr */
  644.     rplacd(list,newcdr);
  645.  
  646.     /* return the list node that was modified */
  647.     return (list);
  648. }
  649.  
  650. /* xnconc - destructively append lists */
  651. NODE *xnconc(args)
  652.   NODE *args;
  653. {
  654.     NODE *list,*last,*val;
  655.  
  656.     /* concatenate each argument */
  657.     for (val = NIL; args; ) {
  658.  
  659.     /* concatenate this list */
  660.     if (list = xlmatch(LIST,&args)) {
  661.  
  662.         /* check for this being the first non-empty list */
  663.         if (val)
  664.         rplacd(last,list);
  665.         else
  666.         val = list;
  667.  
  668.         /* find the end of the list */
  669.         while (consp(cdr(list)))
  670.         list = cdr(list);
  671.  
  672.         /* save the new last element */
  673.         last = list;
  674.     }
  675.     }
  676.  
  677.     /* return the list */
  678.     return (val);
  679. }
  680.  
  681. /* xdelete - built-in function 'delete' */
  682. NODE *xdelete(args)
  683.   NODE *args;
  684. {
  685.     NODE ***oldstk,*x,*list,*fcn,*last,*val;
  686.     int tresult;
  687.  
  688.     /* create a new stack frame */
  689.     oldstk = xlsave(&x,&list,&fcn,NULL);
  690.  
  691.     /* get the expression to delete and the list */
  692.     x = xlarg(&args);
  693.     list = xlmatch(LIST,&args);
  694.     xltest(&fcn,&tresult,&args);
  695.     xllastarg(args);
  696.  
  697.     /* delete leading matches */
  698.     while (consp(list)) {
  699.     if (dotest(x,car(list),fcn) != tresult)
  700.         break;
  701.     list = cdr(list);
  702.     }
  703.     val = last = list;
  704.  
  705.     /* delete embedded matches */
  706.     if (consp(list)) {
  707.  
  708.     /* skip the first non-matching element */
  709.     list = cdr(list);
  710.  
  711.     /* look for embedded matches */
  712.     while (consp(list)) {
  713.  
  714.         /* check to see if this element should be deleted */
  715.         if (dotest(x,car(list),fcn) == tresult)
  716.         rplacd(last,cdr(list));
  717.         else
  718.         last = list;
  719.  
  720.         /* move to the next element */
  721.         list = cdr(list);
  722.      }
  723.     }
  724.  
  725.     /* restore the previous stack frame */
  726.     xlstack = oldstk;
  727.  
  728.     /* return the updated list */
  729.     return (val);
  730. }
  731.  
  732. /* xatom - is this an atom? */
  733. NODE *xatom(args)
  734.   NODE *args;
  735. {
  736.     NODE *arg;
  737.     arg = xlarg(&args);
  738.     xllastarg(args);
  739.     return (atom(arg) ? true : NIL);
  740. }
  741.  
  742. /* xsymbolp - is this an symbol? */
  743. NODE *xsymbolp(args)
  744.   NODE *args;
  745. {
  746.     NODE *arg;
  747.     arg = xlarg(&args);
  748.     xllastarg(args);
  749.     return (arg == NIL || symbolp(arg) ? true : NIL);
  750. }
  751.  
  752. /* xnumberp - is this a number? */
  753. NODE *xnumberp(args)
  754.   NODE *args;
  755. {
  756.     NODE *arg;
  757.     arg = xlarg(&args);
  758.     xllastarg(args);
  759.     return (fixp(arg) || floatp(arg) ? true : NIL);
  760. }
  761.  
  762. /* xboundp - is this a value bound to this symbol? */
  763. NODE *xboundp(args)
  764.   NODE *args;
  765. {
  766.     NODE *sym;
  767.     sym = xlmatch(SYM,&args);
  768.     xllastarg(args);
  769.     return (getvalue(sym) == s_unbound ? NIL : true);
  770. }
  771.  
  772. /* xnull - is this null? */
  773. NODE *xnull(args)
  774.   NODE *args;
  775. {
  776.     NODE *arg;
  777.     arg = xlarg(&args);
  778.     xllastarg(args);
  779.     return (null(arg) ? true : NIL);
  780. }
  781.  
  782. /* xlistp - is this a list? */
  783. NODE *xlistp(args)
  784.   NODE *args;
  785. {
  786.     NODE *arg;
  787.     arg = xlarg(&args);
  788.     xllastarg(args);
  789.     return (listp(arg) ? true : NIL);
  790. }
  791.  
  792. /* xconsp - is this a cons? */
  793. NODE *xconsp(args)
  794.   NODE *args;
  795. {
  796.     NODE *arg;
  797.     arg = xlarg(&args);
  798.     xllastarg(args);
  799.     return (consp(arg) ? true : NIL);
  800. }
  801.  
  802. /* xeq - are these equal? */
  803. NODE *xeq(args)
  804.   NODE *args;
  805. {
  806.     return (cequal(args,eq));
  807. }
  808.  
  809. /* xeql - are these equal? */
  810. NODE *xeql(args)
  811.   NODE *args;
  812. {
  813.     return (cequal(args,eql));
  814. }
  815.  
  816. /* xequal - are these equal? */
  817. NODE *xequal(args)
  818.   NODE *args;
  819. {
  820.     return (cequal(args,equal));
  821. }
  822.  
  823. /* cequal - common eq/eql/equal function */
  824. LOCAL NODE *cequal(args,fcn)
  825.   NODE *args; int (*fcn)();
  826. {
  827.     NODE *arg1,*arg2;
  828.  
  829.     /* get the two arguments */
  830.     arg1 = xlarg(&args);
  831.     arg2 = xlarg(&args);
  832.     xllastarg(args);
  833.  
  834.     /* compare the arguments */
  835.     return ((*fcn)(arg1,arg2) ? true : NIL);
  836. }
  837. 
  838.