home *** CD-ROM | disk | FTP | other *** search
/ Boldly Go Collection / version40.iso / TS / 25D / XSCHEM20.ZIP / XSFUN1.C < prev    next >
C/C++ Source or Header  |  1989-09-14  |  21KB  |  1,020 lines
  1. /* xsfun1.c - xscheme built-in functions - part 1 */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* gensym variables */
  9. static char gsprefix[STRMAX+1] = { 'G',0 };    /* gensym prefix string */
  10. static int gsnumber = 1;            /* gensym number */
  11.  
  12. /* external variables */
  13. extern LVAL xlenv,xlval,default_object,true;
  14. extern LVAL s_unbound;
  15.  
  16. /* external routines */
  17. extern int eq(),eqv(),equal();
  18.  
  19. /* forward declarations */
  20. FORWARD LVAL cxr();
  21. FORWARD LVAL member();
  22. FORWARD LVAL assoc();
  23. FORWARD LVAL nth();
  24. FORWARD LVAL eqtest();
  25.  
  26. /* xcons - construct a new list cell */
  27. LVAL xcons()
  28. {
  29.     LVAL carval,cdrval;
  30.     
  31.     /* get the two arguments */
  32.     carval = xlgetarg();
  33.     cdrval = xlgetarg();
  34.     xllastarg();
  35.  
  36.     /* construct a new cons node */
  37.     return (cons(carval,cdrval));
  38. }
  39.  
  40. /* xcar - built-in function 'car' */
  41. LVAL xcar()
  42. {
  43.     LVAL list;
  44.     list = xlgalist();
  45.     xllastarg();
  46.     return (list ? car(list) : NIL);
  47. }
  48.  
  49. /* xicar - built-in function '%car' */
  50. LVAL xicar()
  51. {
  52.     LVAL arg;
  53.     arg = xlgetarg();
  54.     xllastarg();
  55.     return (car(arg));
  56. }
  57.  
  58. /* xcdr - built-in function 'cdr' */
  59. LVAL xcdr()
  60. {
  61.     LVAL arg;
  62.     arg = xlgalist();
  63.     xllastarg();
  64.     return (arg ? cdr(arg) : NIL);
  65. }
  66.  
  67. /* xicdr - built-in function '%cdr' */
  68. LVAL xicdr()
  69. {
  70.     LVAL arg;
  71.     arg = xlgetarg();
  72.     xllastarg();
  73.     return (cdr(arg));
  74. }
  75.  
  76. /* cxxr functions */
  77. LVAL xcaar() { return (cxr("aa")); }
  78. LVAL xcadr() { return (cxr("da")); }
  79. LVAL xcdar() { return (cxr("ad")); }
  80. LVAL xcddr() { return (cxr("dd")); }
  81.  
  82. /* cxxxr functions */
  83. LVAL xcaaar() { return (cxr("aaa")); }
  84. LVAL xcaadr() { return (cxr("daa")); }
  85. LVAL xcadar() { return (cxr("ada")); }
  86. LVAL xcaddr() { return (cxr("dda")); }
  87. LVAL xcdaar() { return (cxr("aad")); }
  88. LVAL xcdadr() { return (cxr("dad")); }
  89. LVAL xcddar() { return (cxr("add")); }
  90. LVAL xcdddr() { return (cxr("ddd")); }
  91.  
  92. /* cxxxxr functions */
  93. LVAL xcaaaar() { return (cxr("aaaa")); }
  94. LVAL xcaaadr() { return (cxr("daaa")); }
  95. LVAL xcaadar() { return (cxr("adaa")); }
  96. LVAL xcaaddr() { return (cxr("ddaa")); }
  97. LVAL xcadaar() { return (cxr("aada")); }
  98. LVAL xcadadr() { return (cxr("dada")); }
  99. LVAL xcaddar() { return (cxr("adda")); }
  100. LVAL xcadddr() { return (cxr("ddda")); }
  101. LVAL xcdaaar() { return (cxr("aaad")); }
  102. LVAL xcdaadr() { return (cxr("daad")); }
  103. LVAL xcdadar() { return (cxr("adad")); }
  104. LVAL xcdaddr() { return (cxr("ddad")); }
  105. LVAL xcddaar() { return (cxr("aadd")); }
  106. LVAL xcddadr() { return (cxr("dadd")); }
  107. LVAL xcdddar() { return (cxr("addd")); }
  108. LVAL xcddddr() { return (cxr("dddd")); }
  109.  
  110. /* cxr - common car/cdr routine */
  111. LOCAL LVAL cxr(adstr)
  112.   char *adstr;
  113. {
  114.     LVAL list;
  115.  
  116.     /* get the list */
  117.     list = xlgalist();
  118.     xllastarg();
  119.  
  120.     /* perform the car/cdr operations */
  121.     while (*adstr && consp(list))
  122.     list = (*adstr++ == 'a' ? car(list) : cdr(list));
  123.  
  124.     /* make sure the operation succeeded */
  125.     if (*adstr && list)
  126.     xlbadtype(list);
  127.  
  128.     /* return the result */
  129.     return (list);
  130. }
  131.  
  132. /* xsetcar - built-in function 'set-car!' */
  133. LVAL xsetcar()
  134. {
  135.     LVAL arg,newcar;
  136.  
  137.     /* get the cons and the new car */
  138.     arg = xlgacons();
  139.     newcar = xlgetarg();
  140.     xllastarg();
  141.  
  142.     /* replace the car */
  143.     rplaca(arg,newcar);
  144.     return (arg);
  145. }
  146.  
  147. /* xisetcar - built-in function '%set-car!' */
  148. LVAL xisetcar()
  149. {
  150.     LVAL arg,newcar;
  151.  
  152.     /* get the cons and the new car */
  153.     arg = xlgetarg();
  154.     newcar = xlgetarg();
  155.     xllastarg();
  156.  
  157.     /* replace the car */
  158.     rplaca(arg,newcar);
  159.     return (arg);
  160. }
  161.  
  162. /* xsetcdr - built-in function 'set-cdr!' */
  163. LVAL xsetcdr()
  164. {
  165.     LVAL arg,newcdr;
  166.  
  167.     /* get the cons and the new cdr */
  168.     arg = xlgacons();
  169.     newcdr = xlgetarg();
  170.     xllastarg();
  171.  
  172.     /* replace the cdr */
  173.     rplacd(arg,newcdr);
  174.     return (arg);
  175. }
  176.  
  177. /* xisetcdr - built-in function '%set-cdr!' */
  178. LVAL xisetcdr()
  179. {
  180.     LVAL arg,newcdr;
  181.  
  182.     /* get the cons and the new cdr */
  183.     arg = xlgetarg();
  184.     newcdr = xlgetarg();
  185.     xllastarg();
  186.  
  187.     /* replace the cdr */
  188.     rplacd(arg,newcdr);
  189.     return (arg);
  190. }
  191.  
  192. /* xlist - built-in function 'list' */
  193. LVAL xlist()
  194. {
  195.     LVAL last,next,val;
  196.  
  197.     /* initialize the list */
  198.     val = NIL;
  199.  
  200.     /* add each argument to the list */
  201.     if (moreargs()) {
  202.         val = last = cons(nextarg(),NIL);
  203.         while (moreargs()) {
  204.         next = nextarg();
  205.         push(val);
  206.         next = cons(next,NIL);
  207.         rplacd(last,next);
  208.         last = next;
  209.         val = pop();
  210.     }
  211.     }
  212.  
  213.     /* return the list */
  214.     return (val);
  215. }
  216.  
  217. /* xappend - built-in function 'append' */
  218. LVAL xappend()
  219. {
  220.     LVAL next,this,last,val;
  221.  
  222.     /* append each argument */
  223.     for (val = last = NIL; xlargc > 1; )
  224.  
  225.     /* append each element of this list to the result list */
  226.     for (next = xlgalist(); consp(next); next = cdr(next)) {
  227.         push(val);
  228.         this = cons(car(next),NIL);
  229.         val = pop();
  230.         if (last == NIL) val = this;
  231.         else rplacd(last,this);
  232.         last = this;
  233.     }
  234.  
  235.     /* tack on the last argument */
  236.     if (moreargs()) {
  237.     if (last == NIL) val = xlgetarg();
  238.     else rplacd(last,xlgetarg());
  239.     }
  240.  
  241.     /* return the list */
  242.     return (val);
  243. }
  244.  
  245. /* xreverse - built-in function 'reverse' */
  246. LVAL xreverse()
  247. {
  248.     LVAL next,val;
  249.     
  250.     /* get the list to reverse */
  251.     next = xlgalist();
  252.     xllastarg();
  253.  
  254.     /* append each element of this list to the result list */
  255.     for (val = NIL; consp(next); next = cdr(next)) {
  256.     push(val);
  257.     val = cons(car(next),top());
  258.     drop(1);
  259.     }
  260.  
  261.     /* return the list */
  262.     return (val);
  263. }
  264.  
  265. /* xlastpair - built-in function 'last-pair' */
  266. LVAL xlastpair()
  267. {
  268.     LVAL list;
  269.  
  270.     /* get the list */
  271.     list = xlgalist();
  272.     xllastarg();
  273.  
  274.     /* find the last cons */
  275.     if (consp(list))
  276.     while (consp(cdr(list)))
  277.         list = cdr(list);
  278.  
  279.     /* return the last element */
  280.     return (list);
  281. }
  282.  
  283. /* xlength - built-in function 'length' */
  284. LVAL xlength()
  285. {
  286.     FIXTYPE n;
  287.     LVAL arg;
  288.  
  289.     /* get the argument */
  290.     arg = xlgalist();
  291.     xllastarg();
  292.  
  293.     /* find the length */
  294.     for (n = (FIXTYPE)0; consp(arg); ++n)
  295.     arg = cdr(arg);
  296.  
  297.     /* return the length */
  298.     return (cvfixnum(n));
  299. }
  300.  
  301. /* xmember - built-in function 'member' */
  302. LVAL xmember()
  303. {
  304.     return (member(equal));
  305. }
  306.  
  307. /* xmemv - built-in function 'memv' */
  308. LVAL xmemv()
  309. {
  310.     return (member(eqv));
  311. }
  312.  
  313. /* xmemq - built-in function 'memq' */
  314. LVAL xmemq()
  315. {
  316.     return (member(eq));
  317. }
  318.  
  319. /* member - common routine for member/memv/memq */
  320. LOCAL LVAL member(fcn)
  321.   int (*fcn)();
  322. {
  323.     LVAL x,list,val;
  324.  
  325.     /* get the expression to look for and the list */
  326.     x = xlgetarg();
  327.     list = xlgalist();
  328.     xllastarg();
  329.  
  330.     /* look for the expression */
  331.     for (val = NIL; consp(list); list = cdr(list))
  332.     if ((*fcn)(x,car(list))) {
  333.         val = list;
  334.         break;
  335.     }
  336.  
  337.     /* return the result */
  338.     return (val);
  339. }
  340.  
  341. /* xassoc - built-in function 'assoc' */
  342. LVAL xassoc()
  343. {
  344.     return (assoc(equal));
  345. }
  346.  
  347. /* xassv - built-in function 'assv' */
  348. LVAL xassv()
  349. {
  350.     return (assoc(eqv));
  351. }
  352.  
  353. /* xassq - built-in function 'assq' */
  354. LVAL xassq()
  355. {
  356.     return (assoc(eq));
  357. }
  358.  
  359. /* assoc - common routine for assoc/assv/assq */
  360. LOCAL LVAL assoc(fcn)
  361.   int (*fcn)();
  362. {
  363.     LVAL x,alist,pair,val;
  364.  
  365.     /* get the expression to look for and the association list */
  366.     x = xlgetarg();
  367.     alist = xlgalist();
  368.     xllastarg();
  369.  
  370.     /* look for the expression */
  371.     for (val = NIL; consp(alist); alist = cdr(alist))
  372.     if ((pair = car(alist)) && consp(pair))
  373.         if ((*fcn)(x,car(pair),fcn)) {
  374.         val = pair;
  375.         break;
  376.         }
  377.  
  378.     /* return the result */
  379.     return (val);
  380. }
  381.  
  382. /* xlistref - built-in function 'list-ref' */
  383. LVAL xlistref()
  384. {
  385.     return (nth(TRUE));
  386. }
  387.  
  388. /* xlisttail - built-in function 'list-tail' */
  389. LVAL xlisttail()
  390. {
  391.     return (nth(FALSE));
  392. }
  393.  
  394. /* nth - internal nth function */
  395. LOCAL LVAL nth(carflag)
  396.   int carflag;
  397. {
  398.     LVAL list,arg;
  399.     int n;
  400.  
  401.     /* get n and the list */
  402.     list = xlgalist();
  403.     arg = xlgafixnum();
  404.     xllastarg();
  405.  
  406.     /* range check the index */
  407.     if ((n = (int)getfixnum(arg)) < 0)
  408.     xlerror("index out of range",arg);
  409.  
  410.     /* find the nth element */
  411.     for (; consp(list) && n; n--)
  412.     list = cdr(list);
  413.  
  414.     /* make sure the list was long enough */
  415.     if (n)
  416.     xlerror("index out of range",arg);
  417.  
  418.     /* return the list beginning at the nth element */
  419.     return (carflag && consp(list) ? car(list) : list);
  420. }
  421.  
  422. /* xboundp - is this a value bound to this symbol? */
  423. LVAL xboundp()
  424. {
  425.     LVAL sym;
  426.     sym = xlgasymbol();
  427.     xllastarg();
  428.     return (boundp(sym) ? true : NIL);
  429. }
  430.  
  431. /* xsymvalue - get the value of a symbol */
  432. LVAL xsymvalue()
  433. {
  434.     LVAL sym;
  435.     sym = xlgasymbol();
  436.     xllastarg();
  437.     return (getvalue(sym));
  438. }
  439.  
  440. /* xsetsymvalue - set the value of a symbol */
  441. LVAL xsetsymvalue()
  442. {
  443.     LVAL sym,val;
  444.  
  445.     /* get the symbol */
  446.     sym = xlgasymbol();
  447.     val = xlgetarg();
  448.     xllastarg();
  449.  
  450.     /* set the global value */
  451.     setvalue(sym,val);
  452.  
  453.     /* return its value */
  454.     return (val);
  455. }
  456.  
  457. /* xsymplist - get the property list of a symbol */
  458. LVAL xsymplist()
  459. {
  460.     LVAL sym;
  461.  
  462.     /* get the symbol */
  463.     sym = xlgasymbol();
  464.     xllastarg();
  465.  
  466.     /* return the property list */
  467.     return (getplist(sym));
  468. }
  469.  
  470. /* xsetsymplist - set the property list of a symbol */
  471. LVAL xsetsymplist()
  472. {
  473.     LVAL sym,val;
  474.  
  475.     /* get the symbol */
  476.     sym = xlgasymbol();
  477.     val = xlgetarg();
  478.     xllastarg();
  479.  
  480.     /* set the property list */
  481.     setplist(sym,val);
  482.     return (val);
  483. }
  484.  
  485. /* xget - get the value of a property */
  486. LVAL xget()
  487. {
  488.     LVAL sym,prp;
  489.  
  490.     /* get the symbol and property */
  491.     sym = xlgasymbol();
  492.     prp = xlgasymbol();
  493.     xllastarg();
  494.  
  495.     /* retrieve the property value */
  496.     return (xlgetprop(sym,prp));
  497. }
  498.  
  499. /* xput - set the value of a property */
  500. LVAL xput()
  501. {
  502.     LVAL sym,val,prp;
  503.  
  504.     /* get the symbol and property */
  505.     sym = xlgasymbol();
  506.     prp = xlgasymbol();
  507.     val = xlgetarg();
  508.     xllastarg();
  509.  
  510.     /* set the property value */
  511.     xlputprop(sym,val,prp);
  512.  
  513.     /* return the value */
  514.     return (val);
  515. }
  516.  
  517. /* xtheenvironment - built-in function 'the-environment' */
  518. LVAL xtheenvironment()
  519. {
  520.     xllastarg();
  521.     return (xlenv);
  522. }
  523.  
  524. /* xprocenvironment - built-in function 'procedure-environment' */
  525. LVAL xprocenvironment()
  526. {
  527.     LVAL arg;
  528.     arg = xlgaclosure();
  529.     xllastarg();
  530.     return (getenv(arg));
  531. }
  532.  
  533. /* xenvp - built-in function 'environment?' */
  534. LVAL xenvp()
  535. {
  536.     LVAL arg;
  537.     arg = xlgetarg();
  538.     xllastarg();
  539.     return (envp(arg) ? true : NIL);
  540. }
  541.  
  542. /* xenvbindings - built-in function 'environment-bindings' */
  543. LVAL xenvbindings()
  544. {
  545.     LVAL env,frame,names,val,this,last;
  546.     int len,i;
  547.  
  548.     /* get the environment */
  549.     env = xlgetarg();
  550.     xllastarg();
  551.  
  552.     /* check the argument type */
  553.     if (closurep(env))
  554.     env = getenv(env);
  555.     else if (!envp(env))
  556.     xlbadtype(env);
  557.  
  558.     /* initialize */
  559.     frame = car(env);
  560.     names = getelement(frame,0);
  561.     len = getsize(frame);
  562.     check(1);
  563.  
  564.     /* build a list of dotted pairs */
  565.     for (val = last = NIL, i = 1; i < len; ++i, names = cdr(names)) {
  566.     push(val);
  567.     this = cons(cons(car(names),getelement(frame,i)),NIL);
  568.     val = pop();
  569.     if (last) rplacd(last,this);
  570.     else val = this;
  571.     last = this;
  572.     }
  573.     return (val);
  574. }
  575.  
  576. /* xenvparent - built-in function 'environment-parent' */
  577. LVAL xenvparent()
  578. {
  579.     LVAL env;
  580.     env = xlgaenv();
  581.     xllastarg();
  582.     return (cdr(env));
  583. }
  584.  
  585. /* xvector - built-in function 'vector' */
  586. LVAL xvector()
  587. {
  588.     LVAL vect,*p;
  589.     vect = newvector(xlargc);
  590.     for (p = &vect->n_vdata[0]; moreargs(); )
  591.     *p++ = xlgetarg();
  592.     return (vect);
  593. }
  594.  
  595. /* xmakevector - built-in function 'make-vector' */
  596. LVAL xmakevector()
  597. {
  598.     LVAL arg,val,*p;
  599.     int len;
  600.     
  601.     /* get the vector size */
  602.     arg = xlgafixnum();
  603.     len = (int)getfixnum(arg);
  604.  
  605.     /* check for an initialization value */
  606.     if (moreargs()) {
  607.     arg = xlgetarg();    /* get the initializer */
  608.     xllastarg();        /* make sure that's the last argument */
  609.     cpush(arg);        /* save the initializer */
  610.     val = newvector(len);    /* create the vector */
  611.     p = &val->n_vdata[0];    /* initialize the vector */
  612.     for (arg = pop(); --len >= 0; )
  613.         *p++ = arg;
  614.     }
  615.  
  616.     /* no initialization value */
  617.     else
  618.     val = newvector(len);    /* defaults to initializing to NIL */
  619.     
  620.     /* return the new vector */
  621.     return (val);
  622. }
  623.  
  624. /* xvlength - built-in function 'vector-length' */
  625. LVAL xvlength()
  626. {
  627.     LVAL arg;
  628.     arg = xlgavector();
  629.     xllastarg();
  630.     return (cvfixnum((FIXTYPE)getsize(arg)));
  631. }
  632.  
  633. /* xivlength - built-in function '%vector-length' */
  634. LVAL xivlength()
  635. {
  636.     LVAL arg;
  637.     arg = xlgetarg();
  638.     xllastarg();
  639.     return (cvfixnum((FIXTYPE)getsize(arg)));
  640. }
  641.  
  642. /* xvref - built-in function 'vector-ref' */
  643. LVAL xvref()
  644. {
  645.     LVAL vref();
  646.     return (vref(xlgavector()));
  647. }
  648.  
  649. /* xivref - built-in function '%vector-ref' */
  650. LVAL xivref()
  651. {
  652.     LVAL vref();
  653.     return (vref(xlgetarg()));
  654. }
  655.  
  656. /* vref - common code for xvref and xivref */
  657. LOCAL LVAL vref(vector)
  658.   LVAL vector;
  659. {
  660.     LVAL index;
  661.     int i;
  662.  
  663.     /* get the index */
  664.     index = xlgafixnum();
  665.     xllastarg();
  666.  
  667.     /* range check the index */
  668.     if ((i = (int)getfixnum(index)) < 0 || i >= getsize(vector))
  669.     xlerror("index out of range",index);
  670.  
  671.     /* return the vector element */
  672.     return (getelement(vector,i));
  673. }
  674.  
  675. /* xvset - built-in function 'vector-set!' */
  676. LVAL xvset()
  677. {
  678.     LVAL vset();
  679.     return (vset(xlgavector()));
  680. }
  681.  
  682. /* xivset - built-in function '%vector-set!' */
  683. LVAL xivset()
  684. {
  685.     LVAL vset();
  686.     return (vset(xlgetarg()));
  687. }
  688.  
  689. /* vset - common code for xvset and xivset */
  690. LOCAL LVAL vset(vector)
  691.   LVAL vector;
  692. {
  693.     LVAL index,val;
  694.     int i;
  695.  
  696.     /* get the index and the new value */
  697.     index = xlgafixnum();
  698.     val = xlgetarg();
  699.     xllastarg();
  700.  
  701.     /* range check the index */
  702.     if ((i = (int)getfixnum(index)) < 0 || i >= getsize(vector))
  703.     xlerror("index out of range",index);
  704.  
  705.     /* set the vector element and return the value */
  706.     setelement(vector,i,val);
  707.     return (val);
  708. }
  709.  
  710. /* xvectlist - built-in function 'vector->list' */
  711. LVAL xvectlist()
  712. {
  713.     LVAL vect;
  714.     int size;
  715.  
  716.     /* get the vector */
  717.     vect = xlgavector();
  718.     xllastarg();
  719.     
  720.     /* make a list from the vector */
  721.     cpush(vect);
  722.     size = getsize(vect);
  723.     for (xlval = NIL; --size >= 0; )
  724.     xlval = cons(getelement(vect,size),xlval);
  725.     drop(1);
  726.     return (xlval);
  727. }
  728.  
  729. /* xlistvect - built-in function 'list->vector' */
  730. LVAL xlistvect()
  731. {
  732.     LVAL vect,*p;
  733.     int size;
  734.  
  735.     /* get the list */
  736.     xlval = xlgalist();
  737.     xllastarg();
  738.  
  739.     /* make a vector from the list */
  740.     size = length(xlval);
  741.     vect = newvector(size);
  742.     for (p = &vect->n_vdata[0]; --size >= 0; xlval = cdr(xlval))
  743.     *p++ = car(xlval);
  744.     return (vect);
  745. }
  746.  
  747. /* xmakearray - built-in function 'make-array' */
  748. LVAL xmakearray()
  749. {
  750.     LVAL makearray1(),val;
  751.     val = makearray1(xlargc,xlsp);
  752.     drop(xlargc);
  753.     return (val);
  754. }
  755.  
  756. LVAL makearray1(argc,argv)
  757.   int argc; LVAL *argv;
  758. {
  759.     int size,i;
  760.     LVAL arg;
  761.  
  762.     /* check for the end of the list of dimensions */
  763.     if (--argc < 0)
  764.     return (NIL);
  765.  
  766.     /* get this dimension */
  767.     arg = *argv++;
  768.     if (!fixp(arg))
  769.     xlbadtype(arg);
  770.     size = (int)getfixnum(arg);
  771.  
  772.     /* make the new array */
  773.     cpush(newvector(size));
  774.  
  775.     /* fill the array and return it */
  776.     for (i = 0; i < size; ++i)
  777.     setelement(top(),i,makearray1(argc,argv));
  778.     return (pop());
  779. }
  780.  
  781. /* xaref - built-in function 'array-ref' */
  782. LVAL xaref()
  783. {
  784.     LVAL array,index;
  785.     int i;
  786.  
  787.     /* get the array */
  788.     array = xlgavector();
  789.  
  790.     /* get each array index */
  791.     while (xlargc > 1) {
  792.     index = xlgafixnum(); i = (int)getfixnum(index);
  793.     if (i < 0 || i > getsize(array))
  794.         xlerror("index out of range",index);
  795.     array = getelement(array,i);
  796.     if (!vectorp(array))
  797.         xlbadtype(array);
  798.     }
  799.     cpush(array); ++xlargc;
  800.     return (xvref());
  801. }
  802.  
  803. /* xaset - built-in function 'array-set!' */
  804. LVAL xaset()
  805. {
  806.     LVAL array,index;
  807.     int i;
  808.  
  809.     /* get the array */
  810.     array = xlgavector();
  811.  
  812.     /* get each array index */
  813.     while (xlargc > 2) {
  814.     index = xlgafixnum(); i = (int)getfixnum(index);
  815.     if (i < 0 || i > getsize(array))
  816.         xlerror("index out of range",index);
  817.     array = getelement(array,i);
  818.     if (!vectorp(array))
  819.         xlbadtype(array);
  820.     }
  821.     cpush(array); ++xlargc;
  822.     return (xvset());
  823. }
  824.  
  825. /* xnull - built-in function 'null?' */
  826. LVAL xnull()
  827. {
  828.     LVAL arg;
  829.     arg = xlgetarg();
  830.     xllastarg();
  831.     return (null(arg) ? true : NIL);
  832. }
  833.  
  834. /* xatom - built-in function 'atom?' */
  835. LVAL xatom()
  836. {
  837.     LVAL arg;
  838.     arg = xlgetarg();
  839.     xllastarg();
  840.     return (atom(arg) ? true : NIL);
  841. }
  842.  
  843. /* xlistp - built-in function 'list?' */
  844. LVAL xlistp()
  845. {
  846.     LVAL arg;
  847.     arg = xlgetarg();
  848.     xllastarg();
  849.     return (listp(arg) ? true : NIL);
  850. }
  851.  
  852. /* xnumberp - built-in function 'number?' */
  853. LVAL xnumberp()
  854. {
  855.     LVAL arg;
  856.     arg = xlgetarg();
  857.     xllastarg();
  858.     return (numberp(arg) ? true : NIL);
  859. }
  860.  
  861. /* xbooleanp - built-in function 'boolean?' */
  862. LVAL xbooleanp()
  863. {
  864.     LVAL arg;
  865.     arg = xlgetarg();
  866.     xllastarg();
  867.     return (arg == true || arg == NIL ? true : NIL);
  868. }
  869.  
  870. /* xpairp - built-in function 'pair?' */
  871. LVAL xpairp()
  872. {
  873.     LVAL arg;
  874.     arg = xlgetarg();
  875.     xllastarg();
  876.     return (consp(arg) ? true : NIL);
  877. }
  878.  
  879. /* xsymbolp - built-in function 'symbol?' */
  880. LVAL xsymbolp()
  881. {
  882.     LVAL arg;
  883.     arg = xlgetarg();
  884.     xllastarg();
  885.     return (symbolp(arg) ? true : NIL);
  886. }
  887.  
  888. /* xintegerp - built-in function 'integer?' */
  889. LVAL xintegerp()
  890. {
  891.     LVAL arg;
  892.     arg = xlgetarg();
  893.     xllastarg();
  894.     return (fixp(arg) ? true : NIL);
  895. }
  896.  
  897. /* xrealp - built-in function 'real?' */
  898. LVAL xrealp()
  899. {
  900.     LVAL arg;
  901.     arg = xlgetarg();
  902.     xllastarg();
  903.     return (floatp(arg) ? true : NIL);
  904. }
  905.  
  906. /* xcharp - built-in function 'char?' */
  907. LVAL xcharp()
  908. {
  909.     LVAL arg;
  910.     arg = xlgetarg();
  911.     xllastarg();
  912.     return (charp(arg) ? true : NIL);
  913. }
  914.  
  915. /* xstringp - built-in function 'string?' */
  916. LVAL xstringp()
  917. {
  918.     LVAL arg;
  919.     arg = xlgetarg();
  920.     xllastarg();
  921.     return (stringp(arg) ? true : NIL);
  922. }
  923.  
  924. /* xvectorp - built-in function 'vector?' */
  925. LVAL xvectorp()
  926. {
  927.     LVAL arg;
  928.     arg = xlgetarg();
  929.     xllastarg();
  930.     return (vectorp(arg) ? true : NIL);
  931. }
  932.  
  933. /* xprocedurep - built-in function 'procedure?' */
  934. LVAL xprocedurep()
  935. {
  936.     LVAL arg;
  937.     arg = xlgetarg();
  938.     xllastarg();
  939.     return (closurep(arg) ? true : NIL);
  940. }
  941.  
  942. /* xobjectp - built-in function 'object?' */
  943. LVAL xobjectp()
  944. {
  945.     LVAL arg;
  946.     arg = xlgetarg();
  947.     xllastarg();
  948.     return (closurep(arg) ? true : NIL);
  949. }
  950.  
  951. /* xdefaultobjectp - built-in function 'default-object?' */
  952. LVAL xdefaultobjectp()
  953. {
  954.     LVAL arg;
  955.     arg = xlgetarg();
  956.     xllastarg();
  957.     return (arg == default_object ? true : NIL);
  958. }
  959.  
  960. /* xeq - built-in function 'eq?' */
  961. LVAL xeq()
  962. {
  963.     return (eqtest(eq));
  964. }
  965.  
  966. /* xeqv - built-in function 'eqv?' */
  967. LVAL xeqv()
  968. {
  969.     return (eqtest(eqv));
  970. }
  971.  
  972. /* xequal - built-in function 'equal?' */
  973. LVAL xequal()
  974. {
  975.     return (eqtest(equal));
  976. }
  977.  
  978. /* eqtest - common code for eq?/eqv?/equal? */
  979. LOCAL LVAL eqtest(fcn)
  980.   int (*fcn)();
  981. {
  982.     LVAL arg1,arg2;
  983.     arg1 = xlgetarg();
  984.     arg2 = xlgetarg();
  985.     xllastarg();
  986.     return ((*fcn)(arg1,arg2) ? true : NIL);
  987. }
  988.  
  989. /* xgensym - generate a symbol */
  990. LVAL xgensym()
  991. {
  992.     char sym[STRMAX+11]; /* enough space for prefix and number */
  993.     LVAL x;
  994.  
  995.     /* get the prefix or number */
  996.     if (moreargs()) {
  997.     x = xlgetarg();
  998.     switch (ntype(x)) {
  999.     case SYMBOL:
  1000.         x = getpname(x);
  1001.     case STRING:
  1002.         strncpy(gsprefix,getstring(x),STRMAX);
  1003.         gsprefix[STRMAX] = '\0';
  1004.         break;
  1005.     case FIXNUM:
  1006.         gsnumber = getfixnum(x);
  1007.         break;
  1008.     default:
  1009.         xlerror("bad argument type",x);
  1010.     }
  1011.     }
  1012.     xllastarg();
  1013.  
  1014.     /* create the pname of the new symbol */
  1015.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  1016.  
  1017.     /* make a symbol with this print name */
  1018.     return (cvsymbol(sym));
  1019. }
  1020.