home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / XLISP / XLISP12.ARK / XLBFUN.C < prev    next >
Text File  |  1985-02-19  |  8KB  |  342 lines
  1. /* xlbfun.c - xlisp basic builtin functions */
  2.  
  3. #ifdef AZTEC
  4. #include "stdio.h"
  5. #else
  6. #include <stdio.h>
  7. #endif
  8.  
  9. #include "xlisp.h"
  10.  
  11. /* external variables */
  12. extern struct node *xlstack;
  13. extern struct node *s_lambda,*s_nlambda,*s_unbound;
  14.  
  15. /* local variables */
  16. static char gsprefix[STRMAX+1] = { 'G',0 };
  17. static char gsnumber = 1;
  18.  
  19. /* forward declarations */
  20. FORWARD struct node *defun();
  21.  
  22. /* xeval - the builtin function 'eval' */
  23. struct node *xeval(args)
  24.   struct node *args;
  25. {
  26.     struct 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.n_ptr = xlarg(&args);
  33.     xllastarg(args);
  34.  
  35.     /* evaluate the expression */
  36.     val = xleval(expr.n_ptr);
  37.  
  38.     /* restore the previous stack frame */
  39.     xlstack = oldstk;
  40.  
  41.     /* return the expression evaluated */
  42.     return (val);
  43. }
  44.  
  45. /* xapply - the builtin function 'apply' */
  46. struct node *xapply(args)
  47.   struct node *args;
  48. {
  49.     struct 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.n_ptr = xlarg(&args);
  56.     arglist.n_ptr = xlarg(&args);
  57.     xllastarg(args);
  58.  
  59.     /* if the function is a symbol, get its value */
  60.     if (fun.n_ptr && fun.n_ptr->n_type == SYM)
  61.     fun.n_ptr = xleval(fun.n_ptr);
  62.  
  63.     /* apply the function to the arguments */
  64.     val = xlapply(fun.n_ptr,arglist.n_ptr);
  65.  
  66.     /* restore the previous stack frame */
  67.     xlstack = oldstk;
  68.  
  69.     /* return the expression evaluated */
  70.     return (val);
  71. }
  72.  
  73. /* xfuncall - the builtin function 'funcall' */
  74. struct node *xfuncall(args)
  75.   struct node *args;
  76. {
  77.     struct 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.n_ptr = xlarg(&args);
  84.     arglist.n_ptr = args;
  85.  
  86.     /* if the function is a symbol, get its value */
  87.     if (fun.n_ptr && fun.n_ptr->n_type == SYM)
  88.     fun.n_ptr = xleval(fun.n_ptr);
  89.  
  90.     /* apply the function to the arguments */
  91.     val = xlapply(fun.n_ptr,arglist.n_ptr);
  92.  
  93.     /* restore the previous stack frame */
  94.     xlstack = oldstk;
  95.  
  96.     /* return the expression evaluated */
  97.     return (val);
  98. }
  99.  
  100. /* xquote - builtin function to quote an expression */
  101. struct node *xquote(args)
  102.   struct node *args;
  103. {
  104.     /* make sure there is exactly one argument */
  105.     if (args == NULL || args->n_listnext != NULL)
  106.     xlfail("incorrect number of arguments");
  107.  
  108.     /* return the quoted expression */
  109.     return (args->n_listvalue);
  110. }
  111.  
  112. /* xset - builtin function set */
  113. struct node *xset(args)
  114.   struct node *args;
  115. {
  116.     struct node *sym,*val;
  117.  
  118.     /* get the symbol and new value */
  119.     sym = xlmatch(SYM,&args);
  120.     val = xlarg(&args);
  121.     xllastarg(args);
  122.  
  123.     /* assign the symbol the value of argument 2 and the return value */
  124.     assign(sym,val);
  125.  
  126.     /* return the result value */
  127.     return (val);
  128. }
  129.  
  130. /* xsetq - builtin function setq */
  131. struct node *xsetq(args)
  132.   struct node *args;
  133. {
  134.     struct node *oldstk,arg,sym,val;
  135.  
  136.     /* create a new stack frame */
  137.     oldstk = xlsave(&arg,&sym,&val,NULL);
  138.  
  139.     /* initialize */
  140.     arg.n_ptr = args;
  141.  
  142.     /* get the symbol and new value */
  143.     sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
  144.     val.n_ptr = xlevarg(&arg.n_ptr);
  145.     xllastarg(arg.n_ptr);
  146.  
  147.     /* assign the symbol the value of argument 2 and the return value */
  148.     assign(sym.n_ptr,val.n_ptr);
  149.  
  150.     /* restore the previous stack frame */
  151.     xlstack = oldstk;
  152.  
  153.     /* return the result value */
  154.     return (val.n_ptr);
  155. }
  156.  
  157. /* xdefun - builtin function 'defun' */
  158. struct node *xdefun(args)
  159.   struct node *args;
  160. {
  161.     return (defun(args,s_lambda));
  162. }
  163.  
  164. /* xndefun - builtin function 'ndefun' */
  165. struct node *xndefun(args)
  166.   struct node *args;
  167. {
  168.     return (defun(args,s_nlambda));
  169. }
  170.  
  171. /* defun - internal function definition routine */
  172. LOCAL struct node *defun(args,type)
  173.   struct node *args,*type;
  174. {
  175.     struct node *oldstk,sym,fargs,fun;
  176.  
  177.     /* create a new stack frame */
  178.     oldstk = xlsave(&sym,&fargs,&fun,NULL);
  179.  
  180.     /* get the function symbol and formal argument list */
  181.     sym.n_ptr = xlmatch(SYM,&args);
  182.     fargs.n_ptr = xlmatch(LIST,&args);
  183.  
  184.     /* create a new function definition */
  185.     fun.n_ptr = newnode(LIST);
  186.     fun.n_ptr->n_listvalue = type;
  187.     fun.n_ptr->n_listnext = newnode(LIST);
  188.     fun.n_ptr->n_listnext->n_listvalue = fargs.n_ptr;
  189.     fun.n_ptr->n_listnext->n_listnext = args;
  190.  
  191.     /* make the symbol point to a new function definition */
  192.     assign(sym.n_ptr,fun.n_ptr);
  193.  
  194.     /* restore the previous stack frame */
  195.     xlstack = oldstk;
  196.  
  197.     /* return the function symbol */
  198.     return (sym.n_ptr);
  199. }
  200.  
  201. /* xgensym - generate a symbol */
  202. struct node *xgensym(args)
  203.   struct node *args;
  204. {
  205.     char sym[STRMAX+1];
  206.     struct node *x;
  207.  
  208.     /* get the prefix or number */
  209.     if (args) {
  210.     x = xlarg(&args);
  211.     switch (x->n_type) {
  212.     case SYM:
  213.         strcpy(gsprefix,xlsymname(x));
  214.         break;
  215.     case STR:
  216.         strcpy(gsprefix,x->n_str);
  217.         break;
  218.     case INT:
  219.         gsnumber = x->n_int;
  220.         break;
  221.     default:
  222.         xlfail("bad argument type");
  223.     }
  224.     }
  225.     xllastarg(args);
  226.  
  227.     /* create the pname of the new symbol */
  228.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  229.  
  230.     /* make a symbol with this print name */
  231.     return (xlmakesym(sym,DYNAMIC));
  232. }
  233.  
  234. /* xintern - intern a symbol */
  235. struct node *xintern(args)
  236.   struct node *args;
  237. {
  238.     struct node *oldstk,sym;
  239.  
  240.     /* create a new stack frame */
  241.     oldstk = xlsave(&sym,NULL);
  242.  
  243.     /* get the symbol to intern */
  244.     sym.n_ptr = xlmatch(SYM,&args);
  245.     xllastarg(args);
  246.  
  247.     /* intern the symbol */
  248.     sym.n_ptr = xlintern(sym.n_ptr);
  249.  
  250.     /* restore the previous stack frame */
  251.     xlstack = oldstk;
  252.  
  253.     /* return the symbol */
  254.     return (sym.n_ptr);
  255. }
  256.  
  257. /* xsymname - get the print name of a symbol */
  258. struct node *xsymname(args)
  259.   struct node *args;
  260. {
  261.     struct node *sym;
  262.  
  263.     /* get the symbol */
  264.     sym = xlmatch(SYM,&args);
  265.     xllastarg(args);
  266.  
  267.     /* return the print name */
  268.     return (sym->n_symplist->n_listvalue);
  269. }
  270.  
  271. /* xsymplist - get the property list of a symbol */
  272. struct node *xsymplist(args)
  273.   struct node *args;
  274. {
  275.     struct node *sym;
  276.  
  277.     /* get the symbol */
  278.     sym = xlmatch(SYM,&args);
  279.     xllastarg(args);
  280.  
  281.     /* return the property list */
  282.     return (sym->n_symplist->n_listnext);
  283. }
  284.  
  285. /* xget - get the value of a property */
  286. struct node *xget(args)
  287.   struct node *args;
  288. {
  289.     struct node *sym,*prp;
  290.  
  291.     /* get the symbol and property */
  292.     sym = xlmatch(SYM,&args);
  293.     prp = xlmatch(SYM,&args);
  294.     xllastarg(args);
  295.  
  296.     /* retrieve the property value */
  297.     return (xlgetprop(sym,prp));
  298. }
  299.  
  300. /* xputprop - put a property value onto a property list */
  301. struct node *xputprop(args)
  302.   struct node *args;
  303. {
  304.     struct node *oldstk,sym,val,prp;
  305.  
  306.     /* create a new stack frame */
  307.     oldstk = xlsave(&sym,&val,&prp,NULL);
  308.  
  309.     /* get the symbol, value and property */
  310.     sym.n_ptr = xlmatch(SYM,&args);
  311.     val.n_ptr = xlarg(&args);
  312.     prp.n_ptr = xlmatch(SYM,&args);
  313.     xllastarg(args);
  314.  
  315.     /* put the property onto the property list */
  316.     xlputprop(sym.n_ptr,val.n_ptr,prp.n_ptr);
  317.  
  318.     /* restore the previouse stack frame */
  319.     xlstack = oldstk;
  320.  
  321.     /* return the value */
  322.     return (val.n_ptr);
  323. }
  324.  
  325. /* xremprop - remove a property value from a property list */
  326. struct node *xremprop(args)
  327.   struct node *args;
  328. {
  329.     struct node *sym,*prp;
  330.  
  331.     /* get the symbol and property */
  332.     sym = xlmatch(SYM,&args);
  333.     prp = xlmatch(SYM,&args);
  334.     xllastarg(args);
  335.  
  336.     /* remove the property */
  337.     xlremprop(sym,prp);
  338.  
  339.     /* return nil */
  340.     return (NULL);
  341. }
  342.