home *** CD-ROM | disk | FTP | other *** search
/ The C Users' Group Library 1994 August / wc-cdrom-cusersgrouplibrary-1994-08.iso / vol_100 / 176_01 / xlbfun.c < prev    next >
Text File  |  1985-12-27  |  14KB  |  648 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 NODE ***xlstack,*xlenv;
  10. extern NODE *s_car,*s_cdr,*s_nth,*s_get,*s_svalue,*s_splist,*s_aref;
  11. extern NODE *s_lambda,*s_macro;
  12. extern NODE *s_comma,*s_comat;
  13. extern NODE *s_unbound;
  14. extern char gsprefix[];
  15. extern int gsnumber;
  16.  
  17. /* forward declarations */
  18. FORWARD NODE *bquote1();
  19. FORWARD NODE *defun();
  20. FORWARD NODE *makesymbol();
  21.  
  22. /* xeval - the built-in function 'eval' */
  23. NODE *xeval(args)
  24.   NODE *args;
  25. {
  26.     NODE ***oldstk,*expr,*val;
  27.  
  28.     /* create a new stack frame */
  29.     oldstk = xlsave(&expr,NULL);
  30.  
  31.     /* get the expression to evaluate */
  32.     expr = xlarg(&args);
  33.     xllastarg(args);
  34.  
  35.     /* evaluate the expression */
  36.     val = xleval(expr);
  37.  
  38.     /* restore the previous stack frame */
  39.     xlstack = oldstk;
  40.  
  41.     /* return the expression evaluated */
  42.     return (val);
  43. }
  44.  
  45. /* xapply - the built-in function 'apply' */
  46. NODE *xapply(args)
  47.   NODE *args;
  48. {
  49.     NODE ***oldstk,*fun,*arglist,*val;
  50.  
  51.     /* create a new stack frame */
  52.     oldstk = xlsave(&fun,&arglist,NULL);
  53.  
  54.     /* get the function and argument list */
  55.     fun = xlarg(&args);
  56.     arglist = xlmatch(LIST,&args);
  57.     xllastarg(args);
  58.  
  59.     /* if the function is a symbol, get its value */
  60.     if (symbolp(fun))
  61.     fun = xleval(fun);
  62.  
  63.     /* apply the function to the arguments */
  64.     val = xlapply(fun,arglist);
  65.  
  66.     /* restore the previous stack frame */
  67.     xlstack = oldstk;
  68.  
  69.     /* return the expression evaluated */
  70.     return (val);
  71. }
  72.  
  73. /* xfuncall - the built-in function 'funcall' */
  74. NODE *xfuncall(args)
  75.   NODE *args;
  76. {
  77.     NODE ***oldstk,*fun,*arglist,*val;
  78.  
  79.     /* create a new stack frame */
  80.     oldstk = xlsave(&fun,&arglist,NULL);
  81.  
  82.     /* get the function and argument list */
  83.     fun = xlarg(&args);
  84.     arglist = args;
  85.  
  86.     /* if the function is a symbol, get its value */
  87.     if (symbolp(fun))
  88.     fun = xleval(fun);
  89.  
  90.     /* apply the function to the arguments */
  91.     val = xlapply(fun,arglist);
  92.  
  93.     /* restore the previous stack frame */
  94.     xlstack = oldstk;
  95.  
  96.     /* return the expression evaluated */
  97.     return (val);
  98. }
  99.  
  100. /* xquote - built-in function to quote an expression */
  101. NODE *xquote(args)
  102.   NODE *args;
  103. {
  104.     NODE *val;
  105.  
  106.     /* get the argument */
  107.     val = xlarg(&args);
  108.     xllastarg(args);
  109.  
  110.     /* return the quoted expression */
  111.     return (val);
  112. }
  113.  
  114. /* xfunction - built-in function to quote a function */
  115. NODE *xfunction(args)
  116.   NODE *args;
  117. {
  118.     NODE *val;
  119.  
  120.     /* get the argument */
  121.     val = xlarg(&args);
  122.     xllastarg(args);
  123.  
  124.     /* create a closure for lambda expressions */
  125.     if (consp(val) && car(val) == s_lambda)
  126.     val = cons(val,xlenv);
  127.  
  128.     /* otherwise, get the value of a symbol */
  129.     else if (symbolp(val))
  130.     val = xlgetvalue(val);
  131.  
  132.     /* otherwise, its an error */
  133.     else
  134.     xlerror("not a function",val);
  135.  
  136.     /* return the function */
  137.     return (val);
  138. }
  139.  
  140. /* xlambda - lambda function */
  141. NODE *xlambda(args)
  142.   NODE *args;
  143. {
  144.     NODE ***oldstk,*fargs,*closure;
  145.  
  146.     /* create a new stack frame */
  147.     oldstk = xlsave(&fargs,&closure,NULL);
  148.  
  149.     /* get the formal argument list */
  150.     fargs = xlmatch(LIST,&args);
  151.  
  152.     /* create a new function definition */
  153.     closure = cons(fargs,args);
  154.     closure = cons(s_lambda,closure);
  155.     closure = cons(closure,xlenv);
  156.  
  157.     /* restore the previous stack frame */
  158.     xlstack = oldstk;
  159.  
  160.     /* return the closure */
  161.     return (closure);
  162. }
  163.  
  164. /* xbquote - back quote function */
  165. NODE *xbquote(args)
  166.   NODE *args;
  167. {
  168.     NODE ***oldstk,*expr,*val;
  169.  
  170.     /* create a new stack frame */
  171.     oldstk = xlsave(&expr,NULL);
  172.  
  173.     /* get the expression */
  174.     expr = xlarg(&args);
  175.     xllastarg(args);
  176.  
  177.     /* fill in the template */
  178.     val = bquote1(expr);
  179.  
  180.     /* restore the previous stack frame */
  181.     xlstack = oldstk;
  182.  
  183.     /* return the result */
  184.     return (val);
  185. }
  186.  
  187. /* bquote1 - back quote helper function */
  188. LOCAL NODE *bquote1(expr)
  189.   NODE *expr;
  190. {
  191.     NODE ***oldstk,*val,*list,*last,*new;
  192.  
  193.     /* handle atoms */
  194.     if (atom(expr))
  195.     val = expr;
  196.  
  197.     /* handle (comma <expr>) */
  198.     else if (car(expr) == s_comma) {
  199.     if (atom(cdr(expr)))
  200.         xlfail("bad comma expression");
  201.     val = xleval(car(cdr(expr)));
  202.     }
  203.  
  204.     /* handle ((comma-at <expr>) ... ) */
  205.     else if (consp(car(expr)) && car(car(expr)) == s_comat) {
  206.     oldstk = xlsave(&list,&val,NULL);
  207.     if (atom(cdr(car(expr))))
  208.         xlfail("bad comma-at expression");
  209.     list = xleval(car(cdr(car(expr))));
  210.     for (last = NIL; consp(list); list = cdr(list)) {
  211.         new = consa(car(list));
  212.         if (last)
  213.         rplacd(last,new);
  214.         else
  215.         val = new;
  216.         last = new;
  217.     }
  218.     if (last)
  219.         rplacd(last,bquote1(cdr(expr)));
  220.     else
  221.         val = bquote1(cdr(expr));
  222.     xlstack = oldstk;
  223.     }
  224.  
  225.     /* handle any other list */
  226.     else {
  227.     oldstk = xlsave(&val,NULL);
  228.     val = consa(NIL);
  229.     rplaca(val,bquote1(car(expr)));
  230.     rplacd(val,bquote1(cdr(expr)));
  231.     xlstack = oldstk;
  232.     }
  233.  
  234.     /* return the result */
  235.     return (val);
  236. }
  237.  
  238. /* xset - built-in function set */
  239. NODE *xset(args)
  240.   NODE *args;
  241. {
  242.     NODE *sym,*val;
  243.  
  244.     /* get the symbol and new value */
  245.     sym = xlmatch(SYM,&args);
  246.     val = xlarg(&args);
  247.     xllastarg(args);
  248.  
  249.     /* assign the symbol the value of argument 2 and the return value */
  250.     setvalue(sym,val);
  251.  
  252.     /* return the result value */
  253.     return (val);
  254. }
  255.  
  256. /* xsetq - built-in function setq */
  257. NODE *xsetq(args)
  258.   NODE *args;
  259. {
  260.     NODE ***oldstk,*arg,*sym,*val;
  261.  
  262.     /* create a new stack frame */
  263.     oldstk = xlsave(&arg,&sym,&val,NULL);
  264.  
  265.     /* initialize */
  266.     arg = args;
  267.  
  268.     /* handle each pair of arguments */
  269.     while (arg) {
  270.     sym = xlmatch(SYM,&arg);
  271.     val = xlevarg(&arg);
  272.     xlsetvalue(sym,val);
  273.     }
  274.  
  275.     /* restore the previous stack frame */
  276.     xlstack = oldstk;
  277.  
  278.     /* return the result value */
  279.     return (val);
  280. }
  281.  
  282. /* xsetf - built-in function 'setf' */
  283. NODE *xsetf(args)
  284.   NODE *args;
  285. {
  286.     NODE ***oldstk,*arg,*place,*value;
  287.  
  288.     /* create a new stack frame */
  289.     oldstk = xlsave(&arg,&place,&value,NULL);
  290.  
  291.     /* initialize */
  292.     arg = args;
  293.  
  294.     /* handle each pair of arguments */
  295.     while (arg) {
  296.  
  297.     /* get place and value */
  298.     place = xlarg(&arg);
  299.     value = xlevarg(&arg);
  300.  
  301.     /* check the place form */
  302.     if (symbolp(place))
  303.         xlsetvalue(place,value);
  304.     else if (consp(place))
  305.         placeform(place,value);
  306.     else
  307.         xlfail("bad place form");
  308.     }
  309.  
  310.     /* restore the previous stack frame */
  311.     xlstack = oldstk;
  312.  
  313.     /* return the value */
  314.     return (value);
  315. }
  316.  
  317. /* placeform - handle a place form other than a symbol */
  318. LOCAL placeform(place,value)
  319.   NODE *place,*value;
  320. {
  321.     NODE ***oldstk,*fun,*arg1,*arg2;
  322.     int i;
  323.  
  324.     /* check the function name */
  325.     if ((fun = xlmatch(SYM,&place)) == s_get) {
  326.     oldstk = xlsave(&arg1,&arg2,NULL);
  327.     arg1 = xlevmatch(SYM,&place);
  328.     arg2 = xlevmatch(SYM,&place);
  329.     xllastarg(place);
  330.     xlputprop(arg1,value,arg2);
  331.     xlstack = oldstk;
  332.     }
  333.     else if (fun == s_svalue || fun == s_splist) {
  334.     oldstk = xlsave(&arg1,NULL);
  335.     arg1 = xlevmatch(SYM,&place);
  336.     xllastarg(place);
  337.     if (fun == s_svalue)
  338.         setvalue(arg1,value);
  339.     else
  340.         setplist(arg1,value);
  341.     xlstack = oldstk;
  342.     }
  343.     else if (fun == s_car || fun == s_cdr) {
  344.     oldstk = xlsave(&arg1,NULL);
  345.     arg1 = xlevmatch(LIST,&place);
  346.     xllastarg(place);
  347.     if (consp(arg1))
  348.         if (fun == s_car)
  349.         rplaca(arg1,value);
  350.         else
  351.         rplacd(arg1,value);
  352.     xlstack = oldstk;
  353.     }
  354.     else if (fun == s_nth) {
  355.     oldstk = xlsave(&arg1,&arg2,NULL);
  356.     arg1 = xlevmatch(INT,&place);
  357.     arg2 = xlevmatch(LIST,&place);
  358.     xllastarg(place);
  359.     for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
  360.         arg2 = cdr(arg2);
  361.     if (consp(arg2))
  362.         rplaca(arg2,value);
  363.     xlstack = oldstk;
  364.     }
  365.  
  366.     else if (fun == s_aref) {
  367.     oldstk = xlsave(&arg1,&arg2,NULL);
  368.     arg1 = xlevmatch(VECT,&place);
  369.     arg2 = xlevmatch(INT,&place); i = (int)getfixnum(arg2);
  370.     xllastarg(place);
  371.     if (i < 0 || i >= getsize(arg1))
  372.         xlerror("index out of range",arg2);
  373.     setelement(arg1,i,value);
  374.     xlstack = oldstk;
  375.     }
  376.     else
  377.     xlfail("bad place form");
  378. }
  379.                
  380. /* xdefun - built-in function 'defun' */
  381. NODE *xdefun(args)
  382.   NODE *args;
  383. {
  384.     return (defun(args,s_lambda));
  385. }
  386.  
  387. /* xdefmacro - built-in function 'defmacro' */
  388. NODE *xdefmacro(args)
  389.   NODE *args;
  390. {
  391.     return (defun(args,s_macro));
  392. }
  393.  
  394. /* defun - internal function definition routine */
  395. LOCAL NODE *defun(args,type)
  396.   NODE *args,*type;
  397. {
  398.     NODE ***oldstk,*sym,*fargs,*closure;
  399.  
  400.     /* create a new stack frame */
  401.     oldstk = xlsave(&sym,&fargs,&closure,NULL);
  402.  
  403.     /* get the function symbol and formal argument list */
  404.     sym = xlmatch(SYM,&args);
  405.     fargs = xlmatch(LIST,&args);
  406.  
  407.     /* create a new function definition */
  408.     closure = cons(fargs,args);
  409.     closure = cons(type,closure);
  410.     closure = cons(closure,xlenv);
  411.  
  412.     /* make the symbol point to a new function definition */
  413.     xlsetvalue(sym,closure);
  414.  
  415.     /* restore the previous stack frame */
  416.     xlstack = oldstk;
  417.  
  418.     /* return the function symbol */
  419.     return (sym);
  420. }
  421.  
  422. /* xgensym - generate a symbol */
  423. NODE *xgensym(args)
  424.   NODE *args;
  425. {
  426.     char sym[STRMAX+1];
  427.     NODE *x;
  428.  
  429.     /* get the prefix or number */
  430.     if (args) {
  431.     x = xlarg(&args);
  432.     switch (ntype(x)) {
  433.     case STR:
  434.         strcpy(gsprefix,getstring(x));
  435.         break;
  436.     case INT:
  437.         gsnumber = getfixnum(x);
  438.         break;
  439.     default:
  440.         xlerror("bad argument type",x);
  441.     }
  442.     }
  443.     xllastarg(args);
  444.  
  445.     /* create the pname of the new symbol */
  446.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  447.  
  448.     /* make a symbol with this print name */
  449.     return (xlmakesym(sym,DYNAMIC));
  450. }
  451.  
  452. /* xmakesymbol - make a new uninterned symbol */
  453. NODE *xmakesymbol(args)
  454.   NODE *args;
  455. {
  456.     return (makesymbol(args,FALSE));
  457. }
  458.  
  459. /* xintern - make a new interned symbol */
  460. NODE *xintern(args)
  461.   NODE *args;
  462. {
  463.     return (makesymbol(args,TRUE));
  464. }
  465.  
  466. /* makesymbol - make a new symbol */
  467. LOCAL NODE *makesymbol(args,iflag)
  468.   NODE *args; int iflag;
  469. {
  470.     NODE ***oldstk,*pname,*val;
  471.     char *str;
  472.  
  473.     /* create a new stack frame */
  474.     oldstk = xlsave(&pname,NULL);
  475.  
  476.     /* get the print name of the symbol to intern */
  477.     pname = xlmatch(STR,&args);
  478.     xllastarg(args);
  479.  
  480.     /* make the symbol */
  481.     str = getstring(pname);
  482.     val = (iflag ? xlenter(str,DYNAMIC) : xlmakesym(str,DYNAMIC));
  483.  
  484.     /* restore the previous stack frame */
  485.     xlstack = oldstk;
  486.  
  487.     /* return the symbol */
  488.     return (val);
  489. }
  490.  
  491. /* xsymname - get the print name of a symbol */
  492. NODE *xsymname(args)
  493.   NODE *args;
  494. {
  495.     NODE *sym;
  496.  
  497.     /* get the symbol */
  498.     sym = xlmatch(SYM,&args);
  499.     xllastarg(args);
  500.  
  501.     /* return the print name */
  502.     return (getpname(sym));
  503. }
  504.  
  505. /* xsymvalue - get the value of a symbol */
  506. NODE *xsymvalue(args)
  507.   NODE *args;
  508. {
  509.     NODE *sym,*val;
  510.  
  511.     /* get the symbol */
  512.     sym = xlmatch(SYM,&args);
  513.     xllastarg(args);
  514.  
  515.     /* get the global value */
  516.     while ((val = getvalue(sym)) == s_unbound)
  517.     xlcerror("try evaluating symbol again","unbound variable",sym);
  518.  
  519.     /* return its value */
  520.     return (val);
  521. }
  522.  
  523. /* xsymplist - get the property list of a symbol */
  524. NODE *xsymplist(args)
  525.   NODE *args;
  526. {
  527.     NODE *sym;
  528.  
  529.     /* get the symbol */
  530.     sym = xlmatch(SYM,&args);
  531.     xllastarg(args);
  532.  
  533.     /* return the property list */
  534.     return (getplist(sym));
  535. }
  536.  
  537. /* xget - get the value of a property */
  538. NODE *xget(args)
  539.   NODE *args;
  540. {
  541.     NODE *sym,*prp;
  542.  
  543.     /* get the symbol and property */
  544.     sym = xlmatch(SYM,&args);
  545.     prp = xlmatch(SYM,&args);
  546.     xllastarg(args);
  547.  
  548.     /* retrieve the property value */
  549.     return (xlgetprop(sym,prp));
  550. }
  551.  
  552. /* xputprop - set the value of a property */
  553. NODE *xputprop(args)
  554.   NODE *args;
  555. {
  556.     NODE *sym,*val,*prp;
  557.  
  558.     /* get the symbol and property */
  559.     sym = xlmatch(SYM,&args);
  560.     val = xlarg(&args);
  561.     prp = xlmatch(SYM,&args);
  562.     xllastarg(args);
  563.  
  564.     /* set the property value */
  565.     xlputprop(sym,val,prp);
  566.  
  567.     /* return the value */
  568.     return (val);
  569. }
  570.  
  571. /* xremprop - remove a property value from a property list */
  572. NODE *xremprop(args)
  573.   NODE *args;
  574. {
  575.     NODE *sym,*prp;
  576.  
  577.     /* get the symbol and property */
  578.     sym = xlmatch(SYM,&args);
  579.     prp = xlmatch(SYM,&args);
  580.     xllastarg(args);
  581.  
  582.     /* remove the property */
  583.     xlremprop(sym,prp);
  584.  
  585.     /* return nil */
  586.     return (NIL);
  587. }
  588.  
  589. /* xhash - compute the hash value of a string or symbol */
  590. NODE *xhash(args)
  591.   NODE *args;
  592. {
  593.     char *str;
  594.     NODE *val;
  595.     int len;
  596.  
  597.     /* get the string and the table length */
  598.     val = xlarg(&args);
  599.     len = (int)getfixnum(xlmatch(INT,&args));
  600.     xllastarg(args);
  601.  
  602.     /* get the string */
  603.     if (symbolp(val))
  604.     str = getstring(getpname(val));
  605.     else if (stringp(val))
  606.     str = getstring(val);
  607.     else
  608.     xlerror("bad argument type",val);
  609.  
  610.     /* return the hash index */
  611.     return (cvfixnum((FIXNUM)hash(str,len)));
  612. }
  613.  
  614. /* xaref - array reference function */
  615. NODE *xaref(args)
  616.   NODE *args;
  617. {
  618.     NODE *array,*index;
  619.     int i;
  620.  
  621.     /* get the array and the index */
  622.     array = xlmatch(VECT,&args);
  623.     index = xlmatch(INT,&args); i = (int)getfixnum(index);
  624.     xllastarg(args);
  625.  
  626.     /* range check the index */
  627.     if (i < 0 || i >= getsize(array))
  628.     xlerror("array index out of bounds",index);
  629.  
  630.     /* return the array element */
  631.     return (getelement(array,i));
  632. }
  633.  
  634. /* xmkarray - make a new array */
  635. NODE *xmkarray(args)
  636.   NODE *args;
  637. {
  638.     int size;
  639.  
  640.     /* get the size of the array */
  641.     size = (int)getfixnum(xlmatch(INT,&args));
  642.     xllastarg(args);
  643.  
  644.     /* create the array */
  645.     return (newvector(size));
  646. }
  647.  
  648.