home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / XSCHEME2.ZIP / xsfun1.c < prev    next >
C/C++ Source or Header  |  1990-02-28  |  21KB  |  1,057 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. /* xliststar - built-in function 'list*' */
  218. LVAL xliststar()
  219. {
  220.     LVAL last,next,val;
  221.  
  222.     /* initialize the list */
  223.     val = NIL;
  224.  
  225.     /* add each argument to the list */
  226.     if (moreargs()) {
  227.         for (;;) {
  228.         next = nextarg();
  229.         if (moreargs()) {
  230.         push(val);
  231.         next = cons(next,NIL);
  232.         val = pop();
  233.         if (val) rplacd(last,next);
  234.         else val = next;
  235.         last = next;
  236.         }
  237.         else {
  238.         if (val) rplacd(last,next);
  239.         else val = next;
  240.         break;
  241.         }
  242.     }
  243.     }
  244.  
  245.     /* return the list */
  246.     return (val);
  247. }
  248.  
  249. /* xappend - built-in function 'append' */
  250. LVAL xappend()
  251. {
  252.     LVAL next,this,last,val;
  253.  
  254.     /* append each argument */
  255.     for (val = last = NIL; xlargc > 1; )
  256.  
  257.     /* append each element of this list to the result list */
  258.     for (next = xlgalist(); consp(next); next = cdr(next)) {
  259.         push(val);
  260.         this = cons(car(next),NIL);
  261.         val = pop();
  262.         if (last == NIL) val = this;
  263.         else rplacd(last,this);
  264.         last = this;
  265.     }
  266.  
  267.     /* tack on the last argument */
  268.     if (moreargs()) {
  269.     if (last == NIL) val = xlgetarg();
  270.     else rplacd(last,xlgetarg());
  271.     }
  272.  
  273.     /* return the list */
  274.     return (val);
  275. }
  276.  
  277. /* xreverse - built-in function 'reverse' */
  278. LVAL xreverse()
  279. {
  280.     LVAL next,val;
  281.  
  282.     /* get the list to reverse */
  283.     next = xlgalist();
  284.     xllastarg();
  285.  
  286.     /* append each element of this list to the result list */
  287.     for (val = NIL; consp(next); next = cdr(next)) {
  288.     push(val);
  289.     val = cons(car(next),top());
  290.     drop(1);
  291.     }
  292.  
  293.     /* return the list */
  294.     return (val);
  295. }
  296.  
  297. /* xlastpair - built-in function 'last-pair' */
  298. LVAL xlastpair()
  299. {
  300.     LVAL list;
  301.  
  302.     /* get the list */
  303.     list = xlgalist();
  304.     xllastarg();
  305.  
  306.     /* find the last cons */
  307.     if (consp(list))
  308.     while (consp(cdr(list)))
  309.         list = cdr(list);
  310.  
  311.     /* return the last element */
  312.     return (list);
  313. }
  314.  
  315. /* xlength - built-in function 'length' */
  316. LVAL xlength()
  317. {
  318.     FIXTYPE n;
  319.     LVAL arg;
  320.  
  321.     /* get the argument */
  322.     arg = xlgalist();
  323.     xllastarg();
  324.  
  325.     /* find the length */
  326.     for (n = (FIXTYPE)0; consp(arg); ++n)
  327.     arg = cdr(arg);
  328.  
  329.     /* return the length */
  330.     return (cvfixnum(n));
  331. }
  332.  
  333. /* xmember - built-in function 'member' */
  334. LVAL xmember()
  335. {
  336.     return (member(equal));
  337. }
  338.  
  339. /* xmemv - built-in function 'memv' */
  340. LVAL xmemv()
  341. {
  342.     return (member(eqv));
  343. }
  344.  
  345. /* xmemq - built-in function 'memq' */
  346. LVAL xmemq()
  347. {
  348.     return (member(eq));
  349. }
  350.  
  351. /* member - common routine for member/memv/memq */
  352. LOCAL LVAL member(fcn)
  353.   int (*fcn)();
  354. {
  355.     LVAL x,list,val;
  356.  
  357.     /* get the expression to look for and the list */
  358.     x = xlgetarg();
  359.     list = xlgalist();
  360.     xllastarg();
  361.  
  362.     /* look for the expression */
  363.     for (val = NIL; consp(list); list = cdr(list))
  364.     if ((*fcn)(x,car(list))) {
  365.         val = list;
  366.         break;
  367.     }
  368.  
  369.     /* return the result */
  370.     return (val);
  371. }
  372.  
  373. /* xassoc - built-in function 'assoc' */
  374. LVAL xassoc()
  375. {
  376.     return (assoc(equal));
  377. }
  378.  
  379. /* xassv - built-in function 'assv' */
  380. LVAL xassv()
  381. {
  382.     return (assoc(eqv));
  383. }
  384.  
  385. /* xassq - built-in function 'assq' */
  386. LVAL xassq()
  387. {
  388.     return (assoc(eq));
  389. }
  390.  
  391. /* assoc - common routine for assoc/assv/assq */
  392. LOCAL LVAL assoc(fcn)
  393.   int (*fcn)();
  394. {
  395.     LVAL x,alist,pair,val;
  396.  
  397.     /* get the expression to look for and the association list */
  398.     x = xlgetarg();
  399.     alist = xlgalist();
  400.     xllastarg();
  401.  
  402.     /* look for the expression */
  403.     for (val = NIL; consp(alist); alist = cdr(alist))
  404.     if ((pair = car(alist)) && consp(pair))
  405.         if ((*fcn)(x,car(pair),fcn)) {
  406.         val = pair;
  407.         break;
  408.         }
  409.  
  410.     /* return the result */
  411.     return (val);
  412. }
  413.  
  414. /* xlistref - built-in function 'list-ref' */
  415. LVAL xlistref()
  416. {
  417.     return (nth(TRUE));
  418. }
  419.  
  420. /* xlisttail - built-in function 'list-tail' */
  421. LVAL xlisttail()
  422. {
  423.     return (nth(FALSE));
  424. }
  425.  
  426. /* nth - internal nth function */
  427. LOCAL LVAL nth(carflag)
  428.   int carflag;
  429. {
  430.     LVAL list,arg;
  431.     int n;
  432.  
  433.     /* get n and the list */
  434.     list = xlgalist();
  435.     arg = xlgafixnum();
  436.     xllastarg();
  437.  
  438.     /* range check the index */
  439.     if ((n = (int)getfixnum(arg)) < 0)
  440.     xlerror("index out of range",arg);
  441.  
  442.     /* find the nth element */
  443.     for (; consp(list) && n; n--)
  444.     list = cdr(list);
  445.  
  446.     /* make sure the list was long enough */
  447.     if (n)
  448.     xlerror("index out of range",arg);
  449.  
  450.     /* return the list beginning at the nth element */
  451.     return (carflag && consp(list) ? car(list) : list);
  452. }
  453.  
  454. /* xboundp - is this a value bound to this symbol? */
  455. LVAL xboundp()
  456. {
  457.     LVAL sym;
  458.     sym = xlgasymbol();
  459.     xllastarg();
  460.     return (boundp(sym) ? true : NIL);
  461. }
  462.  
  463. /* xsymvalue - get the value of a symbol */
  464. LVAL xsymvalue()
  465. {
  466.     LVAL sym;
  467.     sym = xlgasymbol();
  468.     xllastarg();
  469.     return (getvalue(sym));
  470. }
  471.  
  472. /* xsetsymvalue - set the value of a symbol */
  473. LVAL xsetsymvalue()
  474. {
  475.     LVAL sym,val;
  476.  
  477.     /* get the symbol */
  478.     sym = xlgasymbol();
  479.     val = xlgetarg();
  480.     xllastarg();
  481.  
  482.     /* set the global value */
  483.     setvalue(sym,val);
  484.  
  485.     /* return its value */
  486.     return (val);
  487. }
  488.  
  489. /* xsymplist - get the property list of a symbol */
  490. LVAL xsymplist()
  491. {
  492.     LVAL sym;
  493.  
  494.     /* get the symbol */
  495.     sym = xlgasymbol();
  496.     xllastarg();
  497.  
  498.     /* return the property list */
  499.     return (getplist(sym));
  500. }
  501.  
  502. /* xsetsymplist - set the property list of a symbol */
  503. LVAL xsetsymplist()
  504. {
  505.     LVAL sym,val;
  506.  
  507.     /* get the symbol */
  508.     sym = xlgasymbol();
  509.     val = xlgetarg();
  510.     xllastarg();
  511.  
  512.     /* set the property list */
  513.     setplist(sym,val);
  514.     return (val);
  515. }
  516.  
  517. /* xget - get the value of a property */
  518. LVAL xget()
  519. {
  520.     LVAL sym,prp;
  521.  
  522.     /* get the symbol and property */
  523.     sym = xlgasymbol();
  524.     prp = xlgasymbol();
  525.     xllastarg();
  526.  
  527.     /* retrieve the property value */
  528.     return (xlgetprop(sym,prp));
  529. }
  530.  
  531. /* xput - set the value of a property */
  532. LVAL xput()
  533. {
  534.     LVAL sym,val,prp;
  535.  
  536.     /* get the symbol and property */
  537.     sym = xlgasymbol();
  538.     prp = xlgasymbol();
  539.     val = xlgetarg();
  540.     xllastarg();
  541.  
  542.     /* set the property value */
  543.     xlputprop(sym,val,prp);
  544.  
  545.     /* return the value */
  546.     return (val);
  547. }
  548.  
  549. /* xtheenvironment - built-in function 'the-environment' */
  550. LVAL xtheenvironment()
  551. {
  552.     xllastarg();
  553.     return (xlenv);
  554. }
  555.  
  556. /* xprocenvironment - built-in function 'procedure-environment' */
  557. LVAL xprocenvironment()
  558. {
  559.     LVAL arg;
  560.     arg = xlgaclosure();
  561.     xllastarg();
  562.     return (getenv(arg));
  563. }
  564.  
  565. /* xenvp - built-in function 'environment?' */
  566. LVAL xenvp()
  567. {
  568.     LVAL arg;
  569.     arg = xlgetarg();
  570.     xllastarg();
  571.     return (envp(arg) ? true : NIL);
  572. }
  573.  
  574. /* xenvbindings - built-in function 'environment-bindings' */
  575. LVAL xenvbindings()
  576. {
  577.     LVAL env,frame,names,val,this,last;
  578.     int len,i;
  579.  
  580.     /* get the environment */
  581.     env = xlgetarg();
  582.     xllastarg();
  583.  
  584.     /* check the argument type */
  585.     if (closurep(env))
  586.     env = getenv(env);
  587.     else if (!envp(env))
  588.     xlbadtype(env);
  589.  
  590.     /* initialize */
  591.     frame = car(env);
  592.     names = getelement(frame,0);
  593.     len = getsize(frame);
  594.     check(1);
  595.  
  596.     /* build a list of dotted pairs */
  597.     for (val = last = NIL, i = 1; i < len; ++i, names = cdr(names)) {
  598.     push(val);
  599.     this = cons(cons(car(names),getelement(frame,i)),NIL);
  600.     val = pop();
  601.     if (last) rplacd(last,this);
  602.     else val = this;
  603.     last = this;
  604.     }
  605.     return (val);
  606. }
  607.  
  608. /* xenvparent - built-in function 'environment-parent' */
  609. LVAL xenvparent()
  610. {
  611.     LVAL env;
  612.     env = xlgaenv();
  613.     xllastarg();
  614.     return (cdr(env));
  615. }
  616.  
  617. /* xvector - built-in function 'vector' */
  618. LVAL xvector()
  619. {
  620.     LVAL vect,*p;
  621.     vect = newvector(xlargc);
  622.     for (p = &vect->n_vdata[0]; moreargs(); )
  623.     *p++ = xlgetarg();
  624.     return (vect);
  625. }
  626.  
  627. /* xmakevector - built-in function 'make-vector' */
  628. LVAL xmakevector()
  629. {
  630.     LVAL arg,val,*p;
  631.     int len;
  632.  
  633.     /* get the vector size */
  634.     arg = xlgafixnum();
  635.     len = (int)getfixnum(arg);
  636.  
  637.     /* check for an initialization value */
  638.     if (moreargs()) {
  639.     arg = xlgetarg();    /* get the initializer */
  640.     xllastarg();        /* make sure that's the last argument */
  641.     cpush(arg);        /* save the initializer */
  642.     val = newvector(len);    /* create the vector */
  643.     p = &val->n_vdata[0];    /* initialize the vector */
  644.     for (arg = pop(); --len >= 0; )
  645.         *p++ = arg;
  646.     }
  647.  
  648.     /* no initialization value */
  649.     else
  650.     val = newvector(len);    /* defaults to initializing to NIL */
  651.  
  652.     /* return the new vector */
  653.     return (val);
  654. }
  655.  
  656. /* xvlength - built-in function 'vector-length' */
  657. LVAL xvlength()
  658. {
  659.     LVAL arg;
  660.     arg = xlgavector();
  661.     xllastarg();
  662.     return (cvfixnum((FIXTYPE)getsize(arg)));
  663. }
  664.  
  665. /* xivlength - built-in function '%vector-length' */
  666. LVAL xivlength()
  667. {
  668.     LVAL arg;
  669.     arg = xlgetarg();
  670.     xllastarg();
  671.     return (cvfixnum((FIXTYPE)getsize(arg)));
  672. }
  673.  
  674. /* xvref - built-in function 'vector-ref' */
  675. LVAL xvref()
  676. {
  677.     LVAL vref();
  678.     return (vref(xlgavector()));
  679. }
  680.  
  681. /* xivref - built-in function '%vector-ref' */
  682. LVAL xivref()
  683. {
  684.     LVAL vref();
  685.     return (vref(xlgetarg()));
  686. }
  687.  
  688. /* vref - common code for xvref and xivref */
  689. LOCAL LVAL vref(vector)
  690.   LVAL vector;
  691. {
  692.     LVAL index;
  693.     int i;
  694.  
  695.     /* get the index */
  696.     index = xlgafixnum();
  697.     xllastarg();
  698.  
  699.     /* range check the index */
  700.     if ((i = (int)getfixnum(index)) < 0 || i >= getsize(vector))
  701.     xlerror("index out of range",index);
  702.  
  703.     /* return the vector element */
  704.     return (getelement(vector,i));
  705. }
  706.  
  707. /* xvset - built-in function 'vector-set!' */
  708. LVAL xvset()
  709. {
  710.     LVAL vset();
  711.     return (vset(xlgavector()));
  712. }
  713.  
  714. /* xivset - built-in function '%vector-set!' */
  715. LVAL xivset()
  716. {
  717.     LVAL vset();
  718.     return (vset(xlgetarg()));
  719. }
  720.  
  721. /* vset - common code for xvset and xivset */
  722. LOCAL LVAL vset(vector)
  723.   LVAL vector;
  724. {
  725.     LVAL index,val;
  726.     int i;
  727.  
  728.     /* get the index and the new value */
  729.     index = xlgafixnum();
  730.     val = xlgetarg();
  731.     xllastarg();
  732.  
  733.     /* range check the index */
  734.     if ((i = (int)getfixnum(index)) < 0 || i >= getsize(vector))
  735.     xlerror("index out of range",index);
  736.  
  737.     /* set the vector element and return the value */
  738.     setelement(vector,i,val);
  739.     return (val);
  740. }
  741.  
  742. /* xvectlist - built-in function 'vector->list' */
  743. LVAL xvectlist()
  744. {
  745.     LVAL vect;
  746.     int size;
  747.  
  748.     /* get the vector */
  749.     vect = xlgavector();
  750.     xllastarg();
  751.  
  752.     /* make a list from the vector */
  753.     cpush(vect);
  754.     size = getsize(vect);
  755.     for (xlval = NIL; --size >= 0; )
  756.     xlval = cons(getelement(vect,size),xlval);
  757.     drop(1);
  758.     return (xlval);
  759. }
  760.  
  761. /* xlistvect - built-in function 'list->vector' */
  762. LVAL xlistvect()
  763. {
  764.     LVAL vect,*p;
  765.     int size;
  766.  
  767.     /* get the list */
  768.     xlval = xlgalist();
  769.     xllastarg();
  770.  
  771.     /* make a vector from the list */
  772.     size = length(xlval);
  773.     vect = newvector(size);
  774.     for (p = &vect->n_vdata[0]; --size >= 0; xlval = cdr(xlval))
  775.     *p++ = car(xlval);
  776.     return (vect);
  777. }
  778.  
  779. /* xmakearray - built-in function 'make-array' */
  780. LVAL xmakearray()
  781. {
  782.     LVAL makearray1(),val;
  783.     val = makearray1(xlargc,xlsp);
  784.     drop(xlargc);
  785.     return (val);
  786. }
  787.  
  788. LVAL makearray1(argc,argv)
  789.   int argc; LVAL *argv;
  790. {
  791.     int size,i;
  792.     LVAL arg;
  793.  
  794.     /* check for the end of the list of dimensions */
  795.     if (--argc < 0)
  796.     return (NIL);
  797.  
  798.     /* get this dimension */
  799.     arg = *argv++;
  800.     if (!fixp(arg))
  801.     xlbadtype(arg);
  802.     size = (int)getfixnum(arg);
  803.  
  804.     /* make the new array */
  805.     cpush(newvector(size));
  806.  
  807.     /* fill the array and return it */
  808.     for (i = 0; i < size; ++i)
  809.     setelement(top(),i,makearray1(argc,argv));
  810.     return (pop());
  811. }
  812.  
  813. /* xaref - built-in function 'array-ref' */
  814. LVAL xaref()
  815. {
  816.     LVAL array,index;
  817.     int i;
  818.  
  819.     /* get the array */
  820.     array = xlgavector();
  821.  
  822.     /* get each array index */
  823.     while (xlargc > 1) {
  824.     index = xlgafixnum(); i = (int)getfixnum(index);
  825.     if (i < 0 || i > getsize(array))
  826.         xlerror("index out of range",index);
  827.     array = getelement(array,i);
  828.     if (!vectorp(array))
  829.         xlbadtype(array);
  830.     }
  831.     cpush(array); ++xlargc;
  832.     return (xvref());
  833. }
  834.  
  835. /* xaset - built-in function 'array-set!' */
  836. LVAL xaset()
  837. {
  838.     LVAL array,index;
  839.     int i;
  840.  
  841.     /* get the array */
  842.     array = xlgavector();
  843.  
  844.     /* get each array index */
  845.     while (xlargc > 2) {
  846.     index = xlgafixnum(); i = (int)getfixnum(index);
  847.     if (i < 0 || i > getsize(array))
  848.         xlerror("index out of range",index);
  849.     array = getelement(array,i);
  850.     if (!vectorp(array))
  851.         xlbadtype(array);
  852.     }
  853.     cpush(array); ++xlargc;
  854.     return (xvset());
  855. }
  856.  
  857. /* xnull - built-in function 'null?' */
  858. LVAL xnull()
  859. {
  860.     LVAL arg;
  861.     arg = xlgetarg();
  862.     xllastarg();
  863.     return (null(arg) ? true : NIL);
  864. }
  865.  
  866. /* xatom - built-in function 'atom?' */
  867. LVAL xatom()
  868. {
  869.     LVAL arg;
  870.     arg = xlgetarg();
  871.     xllastarg();
  872.     return (atom(arg) ? true : NIL);
  873. }
  874.  
  875. /* xlistp - built-in function 'list?' */
  876. LVAL xlistp()
  877. {
  878.     LVAL arg;
  879.     arg = xlgetarg();
  880.     xllastarg();
  881.     return (listp(arg) ? true : NIL);
  882. }
  883.  
  884. /* xnumberp - built-in function 'number?' */
  885. LVAL xnumberp()
  886. {
  887.     LVAL arg;
  888.     arg = xlgetarg();
  889.     xllastarg();
  890.     return (numberp(arg) ? true : NIL);
  891. }
  892.  
  893. /* xbooleanp - built-in function 'boolean?' */
  894. LVAL xbooleanp()
  895. {
  896.     LVAL arg;
  897.     arg = xlgetarg();
  898.     xllastarg();
  899.     return (arg == true || arg == NIL ? true : NIL);
  900. }
  901.  
  902. /* xpairp - built-in function 'pair?' */
  903. LVAL xpairp()
  904. {
  905.     LVAL arg;
  906.     arg = xlgetarg();
  907.     xllastarg();
  908.     return (consp(arg) ? true : NIL);
  909. }
  910.  
  911. /* xsymbolp - built-in function 'symbol?' */
  912. LVAL xsymbolp()
  913. {
  914.     LVAL arg;
  915.     arg = xlgetarg();
  916.     xllastarg();
  917.     return (symbolp(arg) ? true : NIL);
  918. }
  919.  
  920. /* xintegerp - built-in function 'integer?' */
  921. LVAL xintegerp()
  922. {
  923.     LVAL arg;
  924.     arg = xlgetarg();
  925.     xllastarg();
  926.     return (fixp(arg) ? true : NIL);
  927. }
  928.  
  929. /* xrealp - built-in function 'real?' */
  930. LVAL xrealp()
  931. {
  932.     LVAL arg;
  933.     arg = xlgetarg();
  934.     xllastarg();
  935.     return (floatp(arg) ? true : NIL);
  936. }
  937.  
  938. /* xcharp - built-in function 'char?' */
  939. LVAL xcharp()
  940. {
  941.     LVAL arg;
  942.     arg = xlgetarg();
  943.     xllastarg();
  944.     return (charp(arg) ? true : NIL);
  945. }
  946.  
  947. /* xstringp - built-in function 'string?' */
  948. LVAL xstringp()
  949. {
  950.     LVAL arg;
  951.     arg = xlgetarg();
  952.     xllastarg();
  953.     return (stringp(arg) ? true : NIL);
  954. }
  955.  
  956. /* xvectorp - built-in function 'vector?' */
  957. LVAL xvectorp()
  958. {
  959.     LVAL arg;
  960.     arg = xlgetarg();
  961.     xllastarg();
  962.     return (vectorp(arg) ? true : NIL);
  963. }
  964.  
  965. #define isprocedure(x) \
  966. (closurep(x) || continuationp(x) || subrp(x) || xsubrp(x))
  967.  
  968. /* xprocedurep - built-in function 'procedure?' */
  969. LVAL xprocedurep()
  970. {
  971.     LVAL arg;
  972.     arg = xlgetarg();
  973.     xllastarg();
  974.     return (isprocedure(arg) ? true : NIL);
  975. }
  976.  
  977. /* xobjectp - built-in function 'object?' */
  978. LVAL xobjectp()
  979. {
  980.     LVAL arg;
  981.     arg = xlgetarg();
  982.     xllastarg();
  983.     return (objectp(arg) ? true : NIL);
  984. }
  985.  
  986. /* xdefaultobjectp - built-in function 'default-object?' */
  987. LVAL xdefaultobjectp()
  988. {
  989.     LVAL arg;
  990.     arg = xlgetarg();
  991.     xllastarg();
  992.     return (arg == default_object ? true : NIL);
  993. }
  994.  
  995. /* xeq - built-in function 'eq?' */
  996. LVAL xeq()
  997. {
  998.     return (eqtest(eq));
  999. }
  1000.  
  1001. /* xeqv - built-in function 'eqv?' */
  1002. LVAL xeqv()
  1003. {
  1004.     return (eqtest(eqv));
  1005. }
  1006.  
  1007. /* xequal - built-in function 'equal?' */
  1008. LVAL xequal()
  1009. {
  1010.     return (eqtest(equal));
  1011. }
  1012.  
  1013. /* eqtest - common code for eq?/eqv?/equal? */
  1014. LOCAL LVAL eqtest(fcn)
  1015.   int (*fcn)();
  1016. {
  1017.     LVAL arg1,arg2;
  1018.     arg1 = xlgetarg();
  1019.     arg2 = xlgetarg();
  1020.     xllastarg();
  1021.     return ((*fcn)(arg1,arg2) ? true : NIL);
  1022. }
  1023.  
  1024. /* xgensym - generate a symbol */
  1025. LVAL xgensym()
  1026. {
  1027.     char sym[STRMAX+11]; /* enough space for prefix and number */
  1028.     LVAL x;
  1029.  
  1030.     /* get the prefix or number */
  1031.     if (moreargs()) {
  1032.     if ((x = xlgetarg()) == NIL)
  1033.         xlerror("bad argument type",x);
  1034.     else
  1035.         switch (ntype(x)) {
  1036.         case SYMBOL:
  1037.         x = getpname(x);
  1038.         case STRING:
  1039.         strncpy(gsprefix,getstring(x),STRMAX);
  1040.         gsprefix[STRMAX] = '\0';
  1041.         break;
  1042.         case FIXNUM:
  1043.         gsnumber = getfixnum(x);
  1044.         break;
  1045.         default:
  1046.         xlerror("bad argument type",x);
  1047.         }
  1048.     }
  1049.     xllastarg();
  1050.  
  1051.     /* create the pname of the new symbol */
  1052.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  1053.  
  1054.     /* make a symbol with this print name */
  1055.     return (cvsymbol(sym));
  1056. }
  1057.