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