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