home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / zip / language / xlisp_21.zoo / xlbfun.c < prev    next >
C/C++ Source or Header  |  1990-02-28  |  13KB  |  679 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_car,s_cdr,s_nth,s_get,s_svalue,s_splist,s_aref;
  12. extern LVAL s_lambda,s_macro;
  13. extern LVAL s_comma,s_comat;
  14. extern LVAL s_unbound;
  15. extern char gsprefix[];
  16. extern int gsnumber;
  17.  
  18. /* external routines */
  19. extern LVAL xlxeval();
  20.  
  21. /* forward declarations */
  22. FORWARD LVAL bquote1();
  23. FORWARD LVAL defun();
  24. FORWARD LVAL makesymbol();
  25.  
  26. /* xeval - the built-in function 'eval' */
  27. LVAL xeval()
  28. {
  29.     LVAL expr;
  30.  
  31.     /* get the expression to evaluate */
  32.     expr = xlgetarg();
  33.     xllastarg();
  34.  
  35.     /* evaluate the expression */
  36.     return (xleval(expr));
  37. }
  38.  
  39. /* xapply - the built-in function 'apply' */
  40. LVAL xapply()
  41. {
  42.     LVAL fun,arglist;
  43.  
  44.     /* get the function and argument list */
  45.     fun = xlgetarg();
  46.     arglist = xlgalist();
  47.     xllastarg();
  48.  
  49.     /* apply the function to the arguments */
  50.     return (xlapply(pushargs(fun,arglist)));
  51. }
  52.  
  53. /* xfuncall - the built-in function 'funcall' */
  54. LVAL xfuncall()
  55. {
  56.     LVAL *newfp;
  57.     int argc;
  58.     
  59.     /* build a new argument stack frame */
  60.     newfp = xlsp;
  61.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  62.     pusharg(xlgetarg());
  63.     pusharg(NIL); /* will be argc */
  64.  
  65.     /* push each argument */
  66.     for (argc = 0; moreargs(); ++argc)
  67.     pusharg(nextarg());
  68.  
  69.     /* establish the new stack frame */
  70.     newfp[2] = cvfixnum((FIXTYPE)argc);
  71.     xlfp = newfp;
  72.  
  73.     /* apply the function to the arguments */
  74.     return (xlapply(argc));
  75. }
  76.  
  77. /* xmacroexpand - expand a macro call repeatedly */
  78. LVAL xmacroexpand()
  79. {
  80.     LVAL form;
  81.     form = xlgetarg();
  82.     xllastarg();
  83.     return (xlexpandmacros(form));
  84. }
  85.  
  86. /* x1macroexpand - expand a macro call */
  87. LVAL x1macroexpand()
  88. {
  89.     LVAL form,fun,args;
  90.  
  91.     /* protect some pointers */
  92.     xlstkcheck(2);
  93.     xlsave(fun);
  94.     xlsave(args);
  95.  
  96.     /* get the form */
  97.     form = xlgetarg();
  98.     xllastarg();
  99.  
  100.     /* expand until the form isn't a macro call */
  101.     if (consp(form)) {
  102.     fun = car(form);        /* get the macro name */
  103.     args = cdr(form);        /* get the arguments */
  104.     if (symbolp(fun) && fboundp(fun)) {
  105.         fun = xlgetfunction(fun);    /* get the expansion function */
  106.         macroexpand(fun,args,&form);
  107.     }
  108.     }
  109.  
  110.     /* restore the stack and return the expansion */
  111.     xlpopn(2);
  112.     return (form);
  113. }
  114.  
  115. /* xatom - is this an atom? */
  116. LVAL xatom()
  117. {
  118.     LVAL arg;
  119.     arg = xlgetarg();
  120.     xllastarg();
  121.     return (atom(arg) ? true : NIL);
  122. }
  123.  
  124. /* xsymbolp - is this an symbol? */
  125. LVAL xsymbolp()
  126. {
  127.     LVAL arg;
  128.     arg = xlgetarg();
  129.     xllastarg();
  130.     return (arg == NIL || symbolp(arg) ? true : NIL);
  131. }
  132.  
  133. /* xnumberp - is this a number? */
  134. LVAL xnumberp()
  135. {
  136.     LVAL arg;
  137.     arg = xlgetarg();
  138.     xllastarg();
  139.     return (fixp(arg) || floatp(arg) ? true : NIL);
  140. }
  141.  
  142. /* xintegerp - is this an integer? */
  143. LVAL xintegerp()
  144. {
  145.     LVAL arg;
  146.     arg = xlgetarg();
  147.     xllastarg();
  148.     return (fixp(arg) ? true : NIL);
  149. }
  150.  
  151. /* xfloatp - is this a float? */
  152. LVAL xfloatp()
  153. {
  154.     LVAL arg;
  155.     arg = xlgetarg();
  156.     xllastarg();
  157.     return (floatp(arg) ? true : NIL);
  158. }
  159.  
  160. /* xcharp - is this a character? */
  161. LVAL xcharp()
  162. {
  163.     LVAL arg;
  164.     arg = xlgetarg();
  165.     xllastarg();
  166.     return (charp(arg) ? true : NIL);
  167. }
  168.  
  169. /* xstringp - is this a string? */
  170. LVAL xstringp()
  171. {
  172.     LVAL arg;
  173.     arg = xlgetarg();
  174.     xllastarg();
  175.     return (stringp(arg) ? true : NIL);
  176. }
  177.  
  178. /* xarrayp - is this an array? */
  179. LVAL xarrayp()
  180. {
  181.     LVAL arg;
  182.     arg = xlgetarg();
  183.     xllastarg();
  184.     return (vectorp(arg) ? true : NIL);
  185. }
  186.  
  187. /* xstreamp - is this a stream? */
  188. LVAL xstreamp()
  189. {
  190.     LVAL arg;
  191.     arg = xlgetarg();
  192.     xllastarg();
  193.     return (streamp(arg) || ustreamp(arg) ? true : NIL);
  194. }
  195.  
  196. /* xobjectp - is this an object? */
  197. LVAL xobjectp()
  198. {
  199.     LVAL arg;
  200.     arg = xlgetarg();
  201.     xllastarg();
  202.     return (objectp(arg) ? true : NIL);
  203. }
  204.  
  205. /* xboundp - is this a value bound to this symbol? */
  206. LVAL xboundp()
  207. {
  208.     LVAL sym;
  209.     sym = xlgasymbol();
  210.     xllastarg();
  211.     return (boundp(sym) ? true : NIL);
  212. }
  213.  
  214. /* xfboundp - is this a functional value bound to this symbol? */
  215. LVAL xfboundp()
  216. {
  217.     LVAL sym;
  218.     sym = xlgasymbol();
  219.     xllastarg();
  220.     return (fboundp(sym) ? true : NIL);
  221. }
  222.  
  223. /* xnull - is this null? */
  224. LVAL xnull()
  225. {
  226.     LVAL arg;
  227.     arg = xlgetarg();
  228.     xllastarg();
  229.     return (null(arg) ? true : NIL);
  230. }
  231.  
  232. /* xlistp - is this a list? */
  233. LVAL xlistp()
  234. {
  235.     LVAL arg;
  236.     arg = xlgetarg();
  237.     xllastarg();
  238.     return (listp(arg) ? true : NIL);
  239. }
  240.  
  241. /* xendp - is this the end of a list? */
  242. LVAL xendp()
  243. {
  244.     LVAL arg;
  245.     arg = xlgalist();
  246.     xllastarg();
  247.     return (null(arg) ? true : NIL);
  248. }
  249.  
  250. /* xconsp - is this a cons? */
  251. LVAL xconsp()
  252. {
  253.     LVAL arg;
  254.     arg = xlgetarg();
  255.     xllastarg();
  256.     return (consp(arg) ? true : NIL);
  257. }
  258.  
  259. /* xeq - are these equal? */
  260. LVAL xeq()
  261. {
  262.     LVAL arg1,arg2;
  263.  
  264.     /* get the two arguments */
  265.     arg1 = xlgetarg();
  266.     arg2 = xlgetarg();
  267.     xllastarg();
  268.  
  269.     /* compare the arguments */
  270.     return (arg1 == arg2 ? true : NIL);
  271. }
  272.  
  273. /* xeql - are these equal? */
  274. LVAL xeql()
  275. {
  276.     LVAL arg1,arg2;
  277.  
  278.     /* get the two arguments */
  279.     arg1 = xlgetarg();
  280.     arg2 = xlgetarg();
  281.     xllastarg();
  282.  
  283.     /* compare the arguments */
  284.     return (eql(arg1,arg2) ? true : NIL);
  285. }
  286.  
  287. /* xequal - are these equal? (recursive) */
  288. LVAL xequal()
  289. {
  290.     LVAL arg1,arg2;
  291.  
  292.     /* get the two arguments */
  293.     arg1 = xlgetarg();
  294.     arg2 = xlgetarg();
  295.     xllastarg();
  296.  
  297.     /* compare the arguments */
  298.     return (equal(arg1,arg2) ? true : NIL);
  299. }
  300.  
  301. /* xset - built-in function set */
  302. LVAL xset()
  303. {
  304.     LVAL sym,val;
  305.  
  306.     /* get the symbol and new value */
  307.     sym = xlgasymbol();
  308.     val = xlgetarg();
  309.     xllastarg();
  310.  
  311.     /* assign the symbol the value of argument 2 and the return value */
  312.     setvalue(sym,val);
  313.  
  314.     /* return the result value */
  315.     return (val);
  316. }
  317.  
  318. /* xgensym - generate a symbol */
  319. LVAL xgensym()
  320. {
  321.     char sym[STRMAX+11]; /* enough space for prefix and number */
  322.     LVAL x;
  323.  
  324.     /* get the prefix or number */
  325.     if (moreargs()) {
  326.     x = xlgetarg();
  327.     switch (ntype(x)) {
  328.     case SYMBOL:
  329.         x = getpname(x);
  330.     case STRING:
  331.         strncpy(gsprefix,getstring(x),STRMAX);
  332.         gsprefix[STRMAX] = '\0';
  333.         break;
  334.     case FIXNUM:
  335.         gsnumber = getfixnum(x);
  336.         break;
  337.     default:
  338.         xlerror("bad argument type",x);
  339.     }
  340.     }
  341.     xllastarg();
  342.  
  343.     /* create the pname of the new symbol */
  344.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  345.  
  346.     /* make a symbol with this print name */
  347.     return (xlmakesym(sym));
  348. }
  349.  
  350. /* xmakesymbol - make a new uninterned symbol */
  351. LVAL xmakesymbol()
  352. {
  353.     return (makesymbol(FALSE));
  354. }
  355.  
  356. /* xintern - make a new interned symbol */
  357. LVAL xintern()
  358. {
  359.     return (makesymbol(TRUE));
  360. }
  361.  
  362. /* makesymbol - make a new symbol */
  363. LOCAL LVAL makesymbol(iflag)
  364.   int iflag;
  365. {
  366.     LVAL pname;
  367.  
  368.     /* get the print name of the symbol to intern */
  369.     pname = xlgastring();
  370.     xllastarg();
  371.  
  372.     /* make the symbol */
  373.     return (iflag ? xlenter(getstring(pname))
  374.               : xlmakesym(getstring(pname)));
  375. }
  376.  
  377. /* xsymname - get the print name of a symbol */
  378. LVAL xsymname()
  379. {
  380.     LVAL sym;
  381.  
  382.     /* get the symbol */
  383.     sym = xlgasymbol();
  384.     xllastarg();
  385.  
  386.     /* return the print name */
  387.     return (getpname(sym));
  388. }
  389.  
  390. /* xsymvalue - get the value of a symbol */
  391. LVAL xsymvalue()
  392. {
  393.     LVAL sym,val;
  394.  
  395.     /* get the symbol */
  396.     sym = xlgasymbol();
  397.     xllastarg();
  398.  
  399.     /* get the global value */
  400.     while ((val = getvalue(sym)) == s_unbound)
  401.     xlunbound(sym);
  402.  
  403.     /* return its value */
  404.     return (val);
  405. }
  406.  
  407. /* xsymfunction - get the functional value of a symbol */
  408. LVAL xsymfunction()
  409. {
  410.     LVAL sym,val;
  411.  
  412.     /* get the symbol */
  413.     sym = xlgasymbol();
  414.     xllastarg();
  415.  
  416.     /* get the global value */
  417.     while ((val = getfunction(sym)) == s_unbound)
  418.     xlfunbound(sym);
  419.  
  420.     /* return its value */
  421.     return (val);
  422. }
  423.  
  424. /* xsymplist - get the property list of a symbol */
  425. LVAL xsymplist()
  426. {
  427.     LVAL sym;
  428.  
  429.     /* get the symbol */
  430.     sym = xlgasymbol();
  431.     xllastarg();
  432.  
  433.     /* return the property list */
  434.     return (getplist(sym));
  435. }
  436.  
  437. /* xget - get the value of a property */
  438. LVAL xget()
  439. {
  440.     LVAL sym,prp;
  441.  
  442.     /* get the symbol and property */
  443.     sym = xlgasymbol();
  444.     prp = xlgasymbol();
  445.     xllastarg();
  446.  
  447.     /* retrieve the property value */
  448.     return (xlgetprop(sym,prp));
  449. }
  450.  
  451. /* xputprop - set the value of a property */
  452. LVAL xputprop()
  453. {
  454.     LVAL sym,val,prp;
  455.  
  456.     /* get the symbol and property */
  457.     sym = xlgasymbol();
  458.     val = xlgetarg();
  459.     prp = xlgasymbol();
  460.     xllastarg();
  461.  
  462.     /* set the property value */
  463.     xlputprop(sym,val,prp);
  464.  
  465.     /* return the value */
  466.     return (val);
  467. }
  468.  
  469. /* xremprop - remove a property value from a property list */
  470. LVAL xremprop()
  471. {
  472.     LVAL sym,prp;
  473.  
  474.     /* get the symbol and property */
  475.     sym = xlgasymbol();
  476.     prp = xlgasymbol();
  477.     xllastarg();
  478.  
  479.     /* remove the property */
  480.     xlremprop(sym,prp);
  481.  
  482.     /* return nil */
  483.     return (NIL);
  484. }
  485.  
  486. /* xhash - compute the hash value of a string or symbol */
  487. LVAL xhash()
  488. {
  489.     unsigned char *str;
  490.     LVAL len,val;
  491.     int n;
  492.  
  493.     /* get the string and the table length */
  494.     val = xlgetarg();
  495.     len = xlgafixnum(); n = (int)getfixnum(len);
  496.     xllastarg();
  497.  
  498.     /* get the string */
  499.     if (symbolp(val))
  500.     str = getstring(getpname(val));
  501.     else if (stringp(val))
  502.     str = getstring(val);
  503.     else
  504.     xlerror("bad argument type",val);
  505.  
  506.     /* return the hash index */
  507.     return (cvfixnum((FIXTYPE)hash(str,n)));
  508. }
  509.  
  510. /* xaref - array reference function */
  511. LVAL xaref()
  512. {
  513.     LVAL array,index;
  514.     int i;
  515.  
  516.     /* get the array and the index */
  517.     array = xlgavector();
  518.     index = xlgafixnum(); i = (int)getfixnum(index);
  519.     xllastarg();
  520.  
  521.     /* range check the index */
  522.     if (i < 0 || i >= getsize(array))
  523.     xlerror("array index out of bounds",index);
  524.  
  525.     /* return the array element */
  526.     return (getelement(array,i));
  527. }
  528.  
  529. /* xmkarray - make a new array */
  530. LVAL xmkarray()
  531. {
  532.     LVAL size;
  533.     int n;
  534.  
  535.     /* get the size of the array */
  536.     size = xlgafixnum() ; n = (int)getfixnum(size);
  537.     xllastarg();
  538.  
  539.     /* create the array */
  540.     return (newvector(n));
  541. }
  542.  
  543. /* xvector - make a vector */
  544. LVAL xvector()
  545. {
  546.     LVAL val;
  547.     int i;
  548.  
  549.     /* make the vector */
  550.     val = newvector(xlargc);
  551.  
  552.     /* store each argument */
  553.     for (i = 0; moreargs(); ++i)
  554.     setelement(val,i,nextarg());
  555.     xllastarg();
  556.  
  557.     /* return the vector */
  558.     return (val);
  559. }
  560.  
  561. /* xerror - special form 'error' */
  562. LVAL xerror()
  563. {
  564.     LVAL emsg,arg;
  565.  
  566.     /* get the error message and the argument */
  567.     emsg = xlgastring();
  568.     arg = (moreargs() ? xlgetarg() : s_unbound);
  569.     xllastarg();
  570.  
  571.     /* signal the error */
  572.     xlerror(getstring(emsg),arg);
  573. }
  574.  
  575. /* xcerror - special form 'cerror' */
  576. LVAL xcerror()
  577. {
  578.     LVAL cmsg,emsg,arg;
  579.  
  580.     /* get the correction message, the error message, and the argument */
  581.     cmsg = xlgastring();
  582.     emsg = xlgastring();
  583.     arg = (moreargs() ? xlgetarg() : s_unbound);
  584.     xllastarg();
  585.  
  586.     /* signal the error */
  587.     xlcerror(getstring(cmsg),getstring(emsg),arg);
  588.  
  589.     /* return nil */
  590.     return (NIL);
  591. }
  592.  
  593. /* xbreak - special form 'break' */
  594. LVAL xbreak()
  595. {
  596.     LVAL emsg,arg;
  597.  
  598.     /* get the error message */
  599.     emsg = (moreargs() ? xlgastring() : NIL);
  600.     arg = (moreargs() ? xlgetarg() : s_unbound);
  601.     xllastarg();
  602.  
  603.     /* enter the break loop */
  604.     xlbreak((emsg ? getstring(emsg) : (unsigned char *)"**BREAK**"),arg);
  605.  
  606.     /* return nil */
  607.     return (NIL);
  608. }
  609.  
  610. /* xcleanup - special form 'clean-up' */
  611. LVAL xcleanup()
  612. {
  613.     xllastarg();
  614.     xlcleanup();
  615. }
  616.  
  617. /* xtoplevel - special form 'top-level' */
  618. LVAL xtoplevel()
  619. {
  620.     xllastarg();
  621.     xltoplevel();
  622. }
  623.  
  624. /* xcontinue - special form 'continue' */
  625. LVAL xcontinue()
  626. {
  627.     xllastarg();
  628.     xlcontinue();
  629. }
  630.  
  631. /* xevalhook - eval hook function */
  632. LVAL xevalhook()
  633. {
  634.     LVAL expr,newehook,newahook,newenv,oldenv,oldfenv,olddenv,val;
  635.  
  636.     /* protect some pointers */
  637.     xlstkcheck(3);
  638.     xlsave(oldenv);
  639.     xlsave(oldfenv);
  640.     xlsave(newenv);
  641.  
  642.     /* get the expression, the new hook functions and the environment */
  643.     expr = xlgetarg();
  644.     newehook = xlgetarg();
  645.     newahook = xlgetarg();
  646.     newenv = (moreargs() ? xlgalist() : NIL);
  647.     xllastarg();
  648.  
  649.     /* bind *evalhook* and *applyhook* to the hook functions */
  650.     olddenv = xldenv;
  651.     xldbind(s_evalhook,newehook);
  652.     xldbind(s_applyhook,newahook);
  653.  
  654.     /* establish the environment for the hook function */
  655.     if (newenv) {
  656.     oldenv = xlenv;
  657.     oldfenv = xlfenv;
  658.     xlenv = car(newenv);
  659.     xlfenv = cdr(newenv);
  660.     }
  661.  
  662.     /* evaluate the expression (bypassing *evalhook*) */
  663.     val = xlxeval(expr);
  664.  
  665.     /* restore the old environment */
  666.     xlunbind(olddenv);
  667.     if (newenv) {
  668.     xlenv = oldenv;
  669.     xlfenv = oldfenv;
  670.     }
  671.  
  672.     /* restore the stack */
  673.     xlpopn(3);
  674.  
  675.     /* return the result */
  676.     return (val);
  677. }
  678.  
  679.