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