home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / xlisp / xlisp12.ark / XLSUBR.C < prev    next >
Encoding:
C/C++ Source or Header  |  1985-02-20  |  2.9 KB  |  136 lines
  1. /* xlsubr - xlisp builtin function support routines */
  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.  
  14. /* xlsubr - define a builtin function */
  15. xlsubr(sname,type,subr)
  16.   char *sname; int type; struct node *(*subr)();
  17. {
  18.     struct node *sym;
  19.  
  20.     /* enter the symbol */
  21.     sym = xlsenter(sname);
  22.  
  23.     /* initialize the value */
  24.     sym->n_symvalue = newnode(type);
  25.     sym->n_symvalue->n_subr = subr;
  26. }
  27.  
  28. /* xlarg - get the next argument */
  29. struct node *xlarg(pargs)
  30.   struct node **pargs;
  31. {
  32.     struct node *arg;
  33.  
  34.     /* make sure the argument exists */
  35.     if (*pargs == NULL)
  36.     xlfail("too few arguments");
  37.  
  38.     /* get the argument value */
  39.     arg = (*pargs)->n_listvalue;
  40.  
  41.     /* move the argument pointer ahead */
  42.     *pargs = (*pargs)->n_listnext;
  43.  
  44.     /* return the argument */
  45.     return (arg);
  46. }
  47.  
  48. /* xlmatch - get an argument and match its type */
  49. struct node *xlmatch(type,pargs)
  50.   int type; struct node **pargs;
  51. {
  52.     struct node *arg;
  53.  
  54.     /* get the argument */
  55.     arg = xlarg(pargs);
  56.  
  57.     /* check its type */
  58.     if (type == LIST) {
  59.     if (arg != NULL && arg->n_type != LIST)
  60.         xlfail("bad argument type");
  61.     }
  62.     else {
  63.     if (arg == NULL || arg->n_type != type)
  64.         xlfail("bad argument type");
  65.     }
  66.  
  67.     /* return the argument */
  68.     return (arg);
  69. }
  70.  
  71. /* xlevarg - get the next argument and evaluate it */
  72. struct node *xlevarg(pargs)
  73.   struct node **pargs;
  74. {
  75.     struct node *oldstk,val;
  76.  
  77.     /* create a new stack frame */
  78.     oldstk = xlsave(&val,NULL);
  79.  
  80.     /* get the argument */
  81.     val.n_ptr = xlarg(pargs);
  82.  
  83.     /* evaluate the argument */
  84.     val.n_ptr = xleval(val.n_ptr);
  85.  
  86.     /* restore the previous stack frame */
  87.     xlstack = oldstk;
  88.  
  89.     /* return the argument */
  90.     return (val.n_ptr);
  91. }
  92.  
  93. /* xlevmatch - get an evaluated argument and match its type */
  94. struct node *xlevmatch(type,pargs)
  95.   int type; struct node **pargs;
  96. {
  97.     struct node *arg;
  98.  
  99.     /* get the argument */
  100.     arg = xlevarg(pargs);
  101.  
  102.     /* check its type */
  103.     if (type == LIST) {
  104.     if (arg != NULL && arg->n_type != LIST)
  105.         xlfail("bad argument type");
  106.     }
  107.     else {
  108.     if (arg == NULL || arg->n_type != type)
  109.         xlfail("bad argument type");
  110.     }
  111.  
  112.     /* return the argument */
  113.     return (arg);
  114. }
  115.  
  116. /* xllastarg - make sure the remainder of the argument list is empty */
  117. xllastarg(args)
  118.   struct node *args;
  119. {
  120.     if (args != NULL)
  121.     xlfail("too many arguments");
  122. }
  123.  
  124. /* assign - assign a value to a symbol */
  125. assign(sym,val)
  126.   struct node *sym,*val;
  127. {
  128.     struct node *lptr;
  129.  
  130.     /* check for a current object */
  131.     if ((lptr = xlobsym(sym)) != NULL)
  132.     lptr->n_listvalue = val;
  133.     else
  134.     sym->n_symvalue = val;
  135. }
  136.