home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / windows / c / xlisp21w / sources / xlbfun.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-08  |  19.0 KB  |  906 lines
  1. /* xlbfun.c - xlisp basic built-in functions */
  2. /*      Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use       */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL xlenv,xlfenv,xldenv,true;
  10. extern LVAL s_evalhook,s_applyhook;
  11. extern LVAL s_unbound, s_quote;
  12. extern char gsprefix[];
  13. extern FIXTYPE gsnumber;
  14.  
  15. /* forward declarations */
  16. #ifdef ANSI
  17. LVAL XNEAR makesymbol(int iflag);
  18. #else
  19. FORWARD LVAL makesymbol();
  20. #endif
  21.  
  22. #if 0   /* original version uses current environment */
  23. /* xeval - the built-in function 'eval' */
  24. LVAL xeval()
  25. {
  26.     LVAL expr;
  27.  
  28.     /* get the expression to evaluate */
  29.     expr = xlgetarg();
  30.     xllastarg();
  31.  
  32.     /* evaluate the expression */
  33.     return (xleval(expr));
  34. }
  35. #else /* Common Lisp compatible version uses global environment */
  36. /* xeval - the built-in function 'eval' */
  37. LVAL xeval()
  38. {
  39.     LVAL expr,oldenv,oldfenv;
  40.  
  41.     /* protect some pointers */
  42.     xlstkcheck(2);
  43.     xlprotect(oldenv);
  44.     xlprotect(oldfenv);
  45.  
  46.     /* get the expression to evaluate */
  47.     expr = xlgetarg();
  48.     xllastarg();
  49.  
  50.     /*establish global environment */
  51.     oldenv = xlenv;
  52.     oldfenv = xlfenv;
  53.     xlenv = xlfenv = NIL;
  54.  
  55.     /* evaluate the expression */
  56.     expr = xleval(expr);
  57.  
  58.     /* restore environment */
  59.     xlenv = oldenv;
  60.     xlfenv = oldfenv;
  61.  
  62.     /* restore the stack */
  63.     xlpopn(2);
  64.  
  65.     /* return evaluated expression */
  66.     return (expr);
  67. }
  68. #endif
  69.  
  70. /* xapply - the built-in function 'apply' */
  71. /* Algorithm based on Luke Tierney's XLISP-STAT */
  72.  
  73. LVAL xapply()
  74. {
  75.     LVAL fun,arglist;
  76.     int n;
  77.  
  78.     if (xlargc < 2) xltoofew();
  79.     if (! listp(xlargv[xlargc - 1])) xlfail("last argument must be a list");
  80.  
  81.     /* protect some pointers */
  82.     xlstkcheck(2);
  83.     xlprotect(arglist);
  84.     xlprotect(fun);
  85.  
  86.     fun = xlgetarg();
  87.     n = xlargc - 1;
  88.     arglist = xlargv[n];
  89.     while (n-- > 0) arglist = cons(xlargv[n], arglist);
  90.  
  91.     /* restore the stack */
  92.     xlpopn(2);
  93.  
  94.     return xlapply(pushargs(fun, arglist));
  95. }
  96.  
  97. /* xfuncall - the built-in function 'funcall' */
  98. LVAL xfuncall()
  99. {
  100.     FRAMEP newfp;
  101.     int argc;
  102.  
  103.     /* build a new argument stack frame */
  104.     newfp = xlsp;
  105.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  106.     pusharg(xlgetarg());
  107.     pusharg(NIL); /* will be argc */
  108.  
  109.     /* push each argument */
  110.     for (argc = 0; moreargs(); ++argc)
  111.         pusharg(nextarg());
  112.  
  113.     /* establish the new stack frame */
  114.     newfp[2] = cvfixnum((FIXTYPE)argc);
  115.     xlfp = newfp;
  116.  
  117.     /* apply the function to the arguments */
  118.     return (xlapply(argc));
  119. }
  120.  
  121. /* xmacroexpand - expand a macro call repeatedly */
  122. LVAL xmacroexpand()
  123. {
  124.     LVAL form;
  125.     form = xlgetarg();
  126.     xllastarg();
  127.     return (xlexpandmacros(form));
  128. }
  129.  
  130. /* x1macroexpand - expand a macro call */
  131. LVAL x1macroexpand()
  132. {
  133.     LVAL form,fun,args;
  134.  
  135.     /* protect some pointers */
  136.     xlstkcheck(2);
  137.     xlsave(fun);
  138.     xlsave(args);
  139.  
  140.     /* get the form */
  141.     form = xlgetarg();
  142.     xllastarg();
  143.  
  144.     /* expand until the form isn't a macro call */
  145.     if (consp(form)) {
  146.         fun = car(form);                /* get the macro name */
  147.         args = cdr(form);               /* get the arguments */
  148.         if (symbolp(fun) && fboundp(fun)) {
  149.             fun = xlgetfunction(fun);   /* get the expansion function */
  150.             macroexpand(fun,args,&form);
  151.         }
  152.     }
  153.  
  154.     /* restore the stack and return the expansion */
  155.     xlpopn(2);
  156.     return (form);
  157. }
  158.  
  159. /* xatom - is this an atom? */
  160. LVAL xatom()
  161. {
  162.     LVAL arg;
  163.     arg = xlgetarg();
  164.     xllastarg();
  165.     return (atom(arg) ? true : NIL);
  166. }
  167.  
  168. /* xsymbolp - is this an symbol? */
  169. LVAL xsymbolp()
  170. {
  171.     LVAL arg;
  172.     arg = xlgetarg();
  173.     xllastarg();
  174.     return (symbolp(arg) ? true : NIL);
  175. }
  176.  
  177. /* xnumberp - is this a number? */
  178. LVAL xnumberp()
  179. {
  180.     LVAL arg;
  181.     arg = xlgetarg();
  182.     xllastarg();
  183. #ifdef COMPLX
  184.     return (numberp(arg) || complexp(arg) ? true : NIL);
  185. #else
  186.     return (fixp(arg) || floatp(arg) ? true : NIL);
  187. #endif
  188. }
  189.  
  190. #ifdef COMPLX
  191. /* xcomplexp - is this a complex number? */
  192. LVAL xcomplexp()
  193. {
  194.     LVAL arg;
  195.     arg = xlgetarg();
  196.     xllastarg();
  197.     return (complexp(arg) ? true : NIL);
  198. }
  199. #endif
  200.  
  201. /* xintegerp - is this an integer? */
  202. LVAL xintegerp()
  203. {
  204.     LVAL arg;
  205.     arg = xlgetarg();
  206.     xllastarg();
  207.     return (fixp(arg) ? true : NIL);
  208. }
  209.  
  210. /* xfloatp - is this a float? */
  211. LVAL xfloatp()
  212. {
  213.     LVAL arg;
  214.     arg = xlgetarg();
  215.     xllastarg();
  216.     return (floatp(arg) ? true : NIL);
  217. }
  218.  
  219. #ifdef RATIOS
  220. LVAL xrationalp()
  221. {
  222.     LVAL arg;
  223.     arg = xlgetarg();
  224.     xllastarg();
  225.     return ((ratiop(arg) || fixp(arg)) ? true : NIL);
  226. }
  227.  
  228. LVAL xnumerator()
  229. {
  230.     LVAL arg;
  231.     arg = xlgetarg();
  232.     xllastarg();
  233.     if (fixp(arg)) return cvfixnum(getfixnum(arg));
  234.     if (ratiop(arg)) return cvfixnum(getnumer(arg));
  235.     xlbadtype(arg);
  236.     return NIL; /* never executes */
  237. }
  238.  
  239. LVAL xdenominator()
  240. {
  241.     LVAL arg;
  242.     arg = xlgetarg();
  243.     xllastarg();
  244.     if (fixp (arg)) return cvfixnum((FIXTYPE)1);
  245.     if (ratiop(arg)) return cvfixnum(getdenom(arg));
  246.     xlbadtype(arg);
  247.     return NIL; /* never executes */
  248. }
  249. #endif
  250.  
  251. /* xcharp - is this a character? */
  252. LVAL xcharp()
  253. {
  254.     LVAL arg;
  255.     arg = xlgetarg();
  256.     xllastarg();
  257.     return (charp(arg) ? true : NIL);
  258. }
  259.  
  260. /* xstringp - is this a string? */
  261. LVAL xstringp()
  262. {
  263.     LVAL arg;
  264.     arg = xlgetarg();
  265.     xllastarg();
  266.     return (stringp(arg) ? true : NIL);
  267. }
  268.  
  269. /* xarrayp - is this an array? */
  270. LVAL xarrayp()
  271. {
  272.     LVAL arg;
  273.     arg = xlgetarg();
  274.     xllastarg();
  275.     return (vectorp(arg) ? true : NIL);
  276. }
  277.  
  278. /* xstreamp - is this a stream? */
  279. LVAL xstreamp()
  280. {
  281.     LVAL arg;
  282.     arg = xlgetarg();
  283.     xllastarg();
  284.     return (streamp(arg) || ustreamp(arg) ? true : NIL);
  285. }
  286.  
  287. /* xopenstreamp - is this an open stream? */
  288. LVAL xopenstreamp()
  289. {
  290.     LVAL arg;
  291.     arg = xlgetarg();
  292.     xllastarg();
  293.     if (ustreamp(arg)) return true;
  294.     if (streamp(arg)) return (getfile(arg) != CLOSED ? true : NIL);
  295.     xlbadtype(arg);
  296.     return NIL; /* never executes */
  297. }
  298.  
  299. /* xinputstreamp - is this an input stream? */
  300. LVAL xinputstreamp()
  301. {
  302.     LVAL arg;
  303.     arg = xlgetarg();
  304.     xllastarg();
  305.     if (ustreamp(arg)) return true;
  306.     if (streamp(arg))
  307.         return (getfile(arg)!=CLOSED && (arg->n_sflags&S_FORREADING)?
  308.             true : NIL);
  309.     xlbadtype(arg);
  310.     return NIL; /* never executes */
  311. }
  312.  
  313. /* xoutputstreamp - is this an output stream? */
  314. LVAL xoutputstreamp()
  315. {
  316.     LVAL arg;
  317.     arg = xlgetarg();
  318.     xllastarg();
  319.     if (ustreamp(arg)) return true;
  320.     if (streamp(arg))
  321.         return (getfile(arg)!=CLOSED && (arg->n_sflags&S_FORWRITING)?
  322.             true : NIL);
  323.     xlbadtype(arg);
  324.     return NIL; /* never executes */
  325. }
  326.  
  327.  
  328. /* xobjectp - is this an object? */
  329. LVAL xobjectp()
  330. {
  331.     LVAL arg;
  332.     arg = xlgetarg();
  333.     xllastarg();
  334.     return (objectp(arg) ? true : NIL);
  335. }
  336.  
  337. /* xboundp - is this a value bound to this symbol? */
  338. LVAL xboundp()
  339. {
  340.     LVAL sym;
  341.     sym = xlgasymornil();   /* TAA fix */
  342.     xllastarg();
  343.     return (boundp(sym) ? true : NIL);
  344. }
  345.  
  346. /* xfboundp - is this a functional value bound to this symbol? */
  347. LVAL xfboundp()
  348. {
  349.     LVAL sym;
  350.     sym = xlgasymornil();   /* TAA fix */
  351.     xllastarg();
  352.     return (fboundp(sym) ? true : NIL);
  353. }
  354.  
  355. /* xconstantp - is this constant? TAA addition*/
  356. LVAL xconstantp()
  357. {
  358.     LVAL arg;
  359.     arg = xlgetarg();
  360.     xllastarg();
  361.  
  362.     if ((!null(arg)) &&
  363.         (((ntype(arg)==CONS) && (car(arg) != s_quote)) ||
  364.          ((ntype(arg)==SYMBOL) && (!constantp(arg)))))
  365.         return (NIL);
  366.     return (true);
  367. }
  368.  
  369. /* xnull - is this null? */
  370. LVAL xnull()
  371. {
  372.     LVAL arg;
  373.     arg = xlgetarg();
  374.     xllastarg();
  375.     return (null(arg) ? true : NIL);
  376. }
  377.  
  378. /* xlistp - is this a list? */
  379. LVAL xlistp()
  380. {
  381.     LVAL arg;
  382.     arg = xlgetarg();
  383.     xllastarg();
  384.     return (listp(arg) ? true : NIL);
  385. }
  386.  
  387. /* xendp - is this the end of a list? */
  388. LVAL xendp()
  389. {
  390.     LVAL arg;
  391.     arg = xlgalist();
  392.     xllastarg();
  393.     return (null(arg) ? true : NIL);
  394. }
  395.  
  396. /* xconsp - is this a cons? */
  397. LVAL xconsp()
  398. {
  399.     LVAL arg;
  400.     arg = xlgetarg();
  401.     xllastarg();
  402.     return (consp(arg) ? true : NIL);
  403. }
  404.  
  405. /* xeq - are these equal? */
  406. LVAL xeq()
  407. {
  408.     LVAL arg1,arg2;
  409.  
  410.     /* get the two arguments */
  411.     arg1 = xlgetarg();
  412.     arg2 = xlgetarg();
  413.     xllastarg();
  414.  
  415.     /* compare the arguments */
  416.     return (arg1 == arg2 ? true : NIL);
  417. }
  418.  
  419. /* xeql - are these equal? */
  420. LVAL xeql()
  421. {
  422.     LVAL arg1,arg2;
  423.  
  424.     /* get the two arguments */
  425.     arg1 = xlgetarg();
  426.     arg2 = xlgetarg();
  427.     xllastarg();
  428.  
  429.     /* compare the arguments */
  430.     return (eql(arg1,arg2) ? true : NIL);
  431. }
  432.  
  433. /* xequal - are these equal? (recursive) */
  434. LVAL xequal()
  435. {
  436.     LVAL arg1,arg2;
  437.  
  438.     /* get the two arguments */
  439.     arg1 = xlgetarg();
  440.     arg2 = xlgetarg();
  441.     xllastarg();
  442.  
  443.     /* compare the arguments */
  444.     return (equal(arg1,arg2) ? true : NIL);
  445. }
  446.  
  447. /* xset - built-in function set */
  448. LVAL xset()
  449. {
  450.     LVAL sym,val;
  451.  
  452.     /* get the symbol and new value */
  453.     sym = xlgasymbol();
  454.     val = xlgetarg();
  455.     xllastarg();
  456.  
  457.     if (constantp(sym)) {
  458.         xlnoassign(sym);
  459.     }
  460.  
  461.     /* assign the symbol the value of argument 2 and the return value */
  462.     setvalue(sym,val);
  463.  
  464.     /* return the result value */
  465.     return (val);
  466. }
  467.  
  468. /* xgensym - generate a symbol */
  469. LVAL xgensym()
  470. {
  471.     char sym[STRMAX+11]; /* enough space for prefix and number */
  472.     LVAL x;
  473.  
  474.     /* get the prefix or number */
  475.     if (moreargs()) {
  476.         x = xlgetarg();
  477.         switch (null(x)? CONS : ntype(x)) { /* was ntype(x)   TAA Mod */
  478.         case SYMBOL:
  479.                 x = getpname(x);
  480.         case STRING:
  481.                 STRNCPY(gsprefix,getstring(x),STRMAX);
  482.                 gsprefix[STRMAX] = '\0';
  483.                 break;
  484.         case FIXNUM:
  485.                 gsnumber = getfixnum(x);
  486.                 break;
  487.         default:
  488.                 xlbadtype(x);
  489.         }
  490.     }
  491.     xllastarg();
  492.  
  493.     /* create the pname of the new symbol */
  494.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  495.  
  496.     /* make a symbol with this print name */
  497.     return (xlmakesym(sym));
  498. }
  499.  
  500. /* xmakesymbol - make a new uninterned symbol */
  501. LVAL xmakesymbol()
  502. {
  503.     return (makesymbol(FALSE));
  504. }
  505.  
  506. /* xintern - make a new interned symbol */
  507. LVAL xintern()
  508. {
  509.     return (makesymbol(TRUE));
  510. }
  511.  
  512. /* makesymbol - make a new symbol */
  513. LOCAL LVAL XNEAR makesymbol(iflag)
  514.   int iflag;
  515. {
  516.     LVAL pname;
  517.         int i;
  518.  
  519.     /* get the print name of the symbol to intern */
  520.     pname = xlgastring();
  521.     xllastarg();
  522.  
  523.     /* check for containing only printable characters */
  524.     i = getslength(pname);
  525.     if (i >= STRMAX)
  526.         xlerror("too long", pname);
  527.     while (i-- > 0) if (pname->n_string[i] < 32 )
  528.         xlerror("non-printing characters",pname);
  529.  
  530.     /* make the symbol */
  531. #ifdef MEDMEM
  532.     STRCPY(buf, getstring(pname));
  533.     return (iflag ? xlenter(buf)
  534.                   : xlmakesym(buf));
  535. #else
  536.     return (iflag ? xlenter(getstring(pname))
  537.                   : xlmakesym(getstring(pname)));
  538. #endif
  539. }
  540.  
  541. /* xsymname - get the print name of a symbol */
  542. LVAL xsymname()
  543. {
  544.     LVAL sym;
  545.  
  546.     /* get the symbol */
  547.     sym = xlgasymornil();   /* TAA fix */
  548.     xllastarg();
  549.  
  550.     /* return the print name */
  551.     return (getpname(sym));
  552. }
  553.  
  554. /* xsymvalue - get the value of a symbol */
  555. LVAL xsymvalue()
  556. {
  557.     LVAL sym,val;
  558.  
  559.     /* get the symbol */
  560.     sym = xlgasymornil();   /* TAA fix */
  561.     xllastarg();
  562.  
  563.     /* get the global value */
  564.     while ((val = getvalue(sym)) == s_unbound)
  565.         xlunbound(sym);
  566.  
  567.     /* return its value */
  568.     return (val);
  569. }
  570.  
  571. /* xsymfunction - get the functional value of a symbol */
  572. LVAL xsymfunction()
  573. {
  574.     LVAL sym,val;
  575.  
  576.     /* get the symbol */
  577.     sym = xlgasymornil();       /* TAA fix */
  578.     xllastarg();
  579.  
  580.     /* get the global value */
  581.     while ((val = getfunction(sym)) == s_unbound)
  582.         xlfunbound(sym);
  583.  
  584.     /* return its value */
  585.     return (val);
  586. }
  587.  
  588. /* xsymplist - get the property list of a symbol */
  589. LVAL xsymplist()
  590. {
  591.     LVAL sym;
  592.  
  593.     /* get the symbol */
  594.     sym = xlgasymornil();   /* TAA fix */
  595.     xllastarg();
  596.  
  597.     /* return the property list */
  598.     return (getplist(sym));
  599. }
  600.  
  601. /* xget - get the value of a property */
  602. LVAL xget()
  603. {
  604.     LVAL sym,prp;
  605.  
  606.     /* get the symbol and property */
  607.     sym = xlgasymbol();
  608.     prp = xlgetarg();
  609.     xllastarg();
  610.  
  611.     /* retrieve the property value */
  612.     return (xlgetprop(sym,prp));
  613. }
  614.  
  615. /* xputprop - set the value of a property */
  616. LVAL xputprop()
  617. {
  618.     LVAL sym,val,prp;
  619.  
  620.     /* get the symbol and property */
  621.     sym = xlgasymbol();
  622.     val = xlgetarg();
  623.     prp = xlgetarg();
  624.     xllastarg();
  625.  
  626.     /* set the property value */
  627.     xlputprop(sym,val,prp);
  628.  
  629.     /* return the value */
  630.     return (val);
  631. }
  632.  
  633. /* xremprop - remove a property value from a property list */
  634. LVAL xremprop()
  635. {
  636.     LVAL sym,prp;
  637.  
  638.     /* get the symbol and property */
  639.     sym = xlgasymbol();
  640.     prp = xlgetarg();
  641.     xllastarg();
  642.  
  643.     /* remove the property */
  644.     xlremprop(sym,prp);
  645.  
  646.     /* return nil */
  647.     return (NIL);
  648. }
  649.  
  650. /* xhash - compute the hash value of a string or symbol */
  651. /* TAA Modified to hash anything */
  652. LVAL xhash()
  653. {
  654.     LVAL len,val;
  655.     int n;
  656.  
  657.     /* get the object and the table length */
  658.     val = xlgetarg();
  659.     len = xlgafixnum(); n = (int)getfixnum(len);
  660.     xllastarg();
  661.  
  662.     /* check for hash arg out of range */
  663.     if (n <= 0) xlbadtype(len);
  664.  
  665.     /* return the hash index */
  666.     return (cvfixnum((FIXTYPE)xlhash(val,n)));
  667. }
  668.  
  669.  
  670.  
  671. /* xaref - array reference function */
  672. LVAL xaref()
  673. {
  674.     LVAL array,index;
  675.     FIXTYPE i;          /* TAA fix */
  676.  
  677.     /* get the array (may be a string) and the index */
  678.     array = xlgetarg();
  679.     array = xlgavector();
  680.     index = xlgafixnum();
  681.     i = getfixnum(index);       /* TAA fix */
  682.     xllastarg();
  683.  
  684.     if (stringp(array)) {   /* extension -- allow fetching chars from string*/
  685.         if (i < 0 || i >= getslength(array))
  686.             xlerror("string index out of bounds",index);
  687.         return (cvchar(getstringch(array,(int)i)));
  688.     }
  689.  
  690.     if (!vectorp(array)) xlbadtype(array);  /* type must be array */
  691.  
  692.     /* range check the index */
  693.     if (i < 0 || i >= getsize(array))
  694.         xlerror("array index out of bounds",index);
  695.  
  696.     /* return the array element */
  697.     return (getelement(array,(int)i));  /* TAA fix -- casting */
  698. }
  699.  
  700. /* xmkarray - make a new array */
  701. LVAL xmkarray()
  702. {
  703.     LVAL size;
  704.     FIXTYPE n;
  705.  
  706.     /* get the size of the array */
  707.     size = xlgafixnum() ; n = getfixnum(size);
  708.     if (n < 0 || n > MAXSLEN )
  709.         xlerror("out of range",size);
  710.     xllastarg();
  711.  
  712.     /* create the array */
  713.     return (newvector((unsigned)n));
  714. }
  715.  
  716. /* xvector - make a vector */
  717. LVAL xvector()
  718. {
  719.     LVAL val;
  720.     int i;
  721.  
  722.     /* make the vector */
  723.     val = newvector(xlargc);
  724.  
  725.     /* store each argument */
  726.     for (i = 0; moreargs(); ++i)
  727.         setelement(val,i,nextarg());
  728.     xllastarg();
  729.  
  730.     /* return the vector */
  731.     return (val);
  732. }
  733.  
  734. /* xerror - special form 'error' */
  735. LVAL xerror()
  736. {
  737.     LVAL emsg,arg;
  738.  
  739.     /* get the error message and the argument */
  740.     emsg = xlgastring();
  741.     arg = (moreargs() ? xlgetarg() : s_unbound);
  742.     xllastarg();
  743.  
  744.     /* signal the error */
  745.     return (xlerror(getstring(emsg),arg));
  746. }
  747.  
  748. /* xcerror - special form 'cerror' */
  749. LVAL xcerror()
  750. {
  751.     LVAL cmsg,emsg,arg;
  752.  
  753.     /* get the correction message, the error message, and the argument */
  754.     cmsg = xlgastring();
  755.     emsg = xlgastring();
  756.     arg = (moreargs() ? xlgetarg() : s_unbound);
  757.     xllastarg();
  758.  
  759.     /* signal the error */
  760.     xlcerror(getstring(cmsg),getstring(emsg),arg);
  761.  
  762.     /* return nil */
  763.     return (NIL);
  764. }
  765.  
  766. /* xbreak - special form 'break' */
  767. LVAL xbreak()
  768. {
  769.     LVAL emsg,arg;
  770.  
  771.     /* get the error message */
  772.     emsg = (moreargs() ? xlgastring() : NIL);
  773.     arg = (moreargs() ? xlgetarg() : s_unbound);
  774.     xllastarg();
  775.  
  776.     /* enter the break loop */
  777.     xlbreak((!null(emsg) ? getstring(emsg) : (char XFAR *)"**BREAK**"),arg);
  778.  
  779.     /* return nil */
  780.     return (NIL);
  781. }
  782.  
  783. /* xcleanup - special form 'clean-up' */
  784. LVAL xcleanup()
  785. {
  786.     xllastarg();
  787.     xlcleanup();
  788.     return (NIL);
  789. }
  790.  
  791. /* xtoplevel - special form 'top-level' */
  792. LVAL xtoplevel()
  793. {
  794.     xllastarg();
  795.     xltoplevel();
  796.     return (NIL);
  797. }
  798.  
  799. /* xcontinue - special form 'continue' */
  800. LVAL xcontinue()
  801. {
  802.     xllastarg();
  803.     xlcontinue();
  804.     return (NIL);
  805. }
  806.  
  807. /* xevalhook - eval hook function */
  808. LVAL xevalhook()
  809. {
  810.     LVAL expr,newehook,newahook,newenv,oldenv,oldfenv,olddenv,val;
  811.  
  812.     /* protect some pointers */
  813.     xlstkcheck(3);
  814. #if 0   /* old way (see below) */
  815.     xlsave(oldenv);
  816.     xlsave(oldfenv);
  817.     xlsave(newenv);
  818. #else /* TAA MOD -- see below */
  819.     xlprotect(oldenv);
  820.     xlprotect(oldfenv);
  821.     xlprotect(newenv);
  822. #endif
  823.  
  824.     /* get the expression, the new hook functions and the environment */
  825.     expr = xlgetarg();
  826.     newehook = xlgetarg();
  827.     newahook = xlgetarg();
  828.     newenv = (moreargs() ? xlgalist() : NIL);
  829.     xllastarg();
  830.  
  831.     /* bind *evalhook* and *applyhook* to the hook functions */
  832.     olddenv = xldenv;
  833.     xldbind(s_evalhook,newehook);
  834.     xldbind(s_applyhook,newahook);
  835.  
  836.     /* establish the environment for the hook function */
  837. #if 0   /* old way, if env is NIL then uses current environment */
  838.     if (!null(newenv)) {
  839.         oldenv = xlenv;
  840.         oldfenv = xlfenv;
  841.         xlenv = car(newenv);
  842.         xlfenv = cdr(newenv);
  843.     }
  844. #else   /* TAA MOD -- if env is NIL then uses global environment */
  845.     oldenv = xlenv;
  846.     oldfenv = xlfenv;
  847.     if (!null(newenv)) {
  848.         xlenv = car(newenv);
  849.         xlfenv = cdr(newenv);
  850.     }
  851.     else {
  852.         xlenv = xlfenv = NIL;
  853.     }
  854. #endif
  855.     /* evaluate the expression (bypassing *evalhook*) */
  856.     val = xlxeval(expr);
  857.  
  858.     /* restore the old environment */
  859.     xlunbind(olddenv);
  860. #if 0
  861.     if (!null(newenv)) {
  862.         xlenv = oldenv;
  863.         xlfenv = oldfenv;
  864.     }
  865. #else
  866.     xlenv = oldenv;
  867.     xlfenv = oldfenv;
  868. #endif
  869.  
  870.     /* restore the stack */
  871.     xlpopn(3);
  872.  
  873.     /* return the result */
  874.     return (val);
  875. }
  876.  
  877. #ifdef APPLYHOOK
  878. /* xapplyhook - apply hook function */
  879. LVAL xapplyhook()
  880. {
  881.     LVAL fcn,args,newehook,newahook,olddenv,val;
  882.  
  883.     /* get the function, arguments, and the new hook functions */
  884.     fcn = xlgetarg();
  885.     args = xlgetarg();
  886.     newehook = xlgetarg();
  887.     newahook = xlgetarg();
  888.     xllastarg();
  889.  
  890.     /* bind *evalhook* and *applyhook* to the hook functions */
  891.     olddenv = xldenv;
  892.     xldbind(s_evalhook,newehook);
  893.     xldbind(s_applyhook,newahook);
  894.  
  895.     /* apply function (apply always bypasses hooks) */
  896.     val = xlapply(pushargs(fcn,args));
  897.  
  898.     /* restore the old environment */
  899.     xlunbind(olddenv);
  900.  
  901.     /* return the result */
  902.     return (val);
  903. }
  904.  
  905. #endif
  906.