home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / xlispdos / source / xlsubr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1986-05-17  |  4.7 KB  |  221 lines
  1. /* xlsubr - xlisp builtin function support routines */
  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 *k_test,*k_tnot,*s_eql;
  10.  
  11. /* xlsubr - define a builtin function */
  12. xlsubr(sname,type,subr)
  13.   char *sname; int type; NODE *(*subr)();
  14. {
  15.     NODE *sym;
  16.  
  17.     /* enter the symbol */
  18.     sym = xlsenter(sname);
  19.  
  20.     /* initialize the value */
  21.     setvalue(sym,cvsubr(subr,type));
  22. }
  23.  
  24. /* xlarg - get the next argument */
  25. NODE *xlarg(pargs)
  26.   NODE **pargs;
  27. {
  28.     NODE *arg;
  29.  
  30.     /* make sure the argument exists */
  31.     if (!consp(*pargs))
  32.     xlfail("too few arguments");
  33.  
  34.     /* get the argument value */
  35.     arg = car(*pargs);
  36.  
  37.     /* move the argument pointer ahead */
  38.     *pargs = cdr(*pargs);
  39.  
  40.     /* return the argument */
  41.     return (arg);
  42. }
  43.  
  44. /* xlmatch - get an argument and match its type */
  45. NODE *xlmatch(type,pargs)
  46.   int type; NODE **pargs;
  47. {
  48.     NODE *arg;
  49.  
  50.     /* get the argument */
  51.     arg = xlarg(pargs);
  52.  
  53.     /* check its type */
  54.     if (type == LIST) {
  55.     if (arg && ntype(arg) != LIST)
  56.         xlerror("bad argument type",arg);
  57.     }
  58.     else {
  59.     if (arg == NIL || ntype(arg) != type)
  60.         xlerror("bad argument type",arg);
  61.     }
  62.  
  63.     /* return the argument */
  64.     return (arg);
  65. }
  66.  
  67. /* xlevarg - get the next argument and evaluate it */
  68. NODE *xlevarg(pargs)
  69.   NODE **pargs;
  70. {
  71.     NODE ***oldstk,*val;
  72.  
  73.     /* create a new stack frame */
  74.     oldstk = xlstack;
  75.     xlsave1(val);
  76.  
  77.     /* get the argument */
  78.     val = xlarg(pargs);
  79.  
  80.     /* evaluate the argument */
  81.     val = xleval(val);
  82.  
  83.     /* restore the previous stack frame */
  84.     xlstack = oldstk;
  85.  
  86.     /* return the argument */
  87.     return (val);
  88. }
  89.  
  90. /* xlevmatch - get an evaluated argument and match its type */
  91. NODE *xlevmatch(type,pargs)
  92.   int type; NODE **pargs;
  93. {
  94.     NODE *arg;
  95.  
  96.     /* get the argument */
  97.     arg = xlevarg(pargs);
  98.  
  99.     /* check its type */
  100.     if (type == LIST) {
  101.     if (arg && ntype(arg) != LIST)
  102.         xlerror("bad argument type",arg);
  103.     }
  104.     else {
  105.     if (arg == NIL || ntype(arg) != type)
  106.         xlerror("bad argument type",arg);
  107.     }
  108.  
  109.     /* return the argument */
  110.     return (arg);
  111. }
  112.  
  113. /* xltest - get the :test or :test-not keyword argument */
  114. xltest(pfcn,ptresult,pargs)
  115.   NODE **pfcn; int *ptresult; NODE **pargs;
  116. {
  117.     NODE *arg;
  118.  
  119.     /* default the argument to eql */
  120.     if (!consp(*pargs)) {
  121.     *pfcn = getvalue(s_eql);
  122.     *ptresult = TRUE;
  123.     return;
  124.     }
  125.  
  126.     /* get the keyword */
  127.     arg = car(*pargs);
  128.  
  129.     /* check the keyword */
  130.     if (arg == k_test)
  131.     *ptresult = TRUE;
  132.     else if (arg == k_tnot)
  133.     *ptresult = FALSE;
  134.     else
  135.     xlfail("expecting :test or :test-not");
  136.  
  137.     /* move the argument pointer ahead */
  138.     *pargs = cdr(*pargs);
  139.  
  140.     /* make sure the argument exists */
  141.     if (!consp(*pargs))
  142.     xlfail("no value for keyword argument");
  143.  
  144.     /* get the argument value */
  145.     *pfcn = car(*pargs);
  146.  
  147.     /* if its a symbol, get its value */
  148.     if (symbolp(*pfcn))
  149.     *pfcn = xleval(*pfcn);
  150.  
  151.     /* move the argument pointer ahead */
  152.     *pargs = cdr(*pargs);
  153. }
  154.  
  155. /* xlgetfile - get a file or stream */
  156. NODE *xlgetfile(pargs)
  157.   NODE **pargs;
  158. {
  159.     NODE *arg;
  160.  
  161.     /* get a file or stream (cons) or nil */
  162.     if (arg = xlarg(pargs)) {
  163.     if (filep(arg)) {
  164.         if (arg->n_fp == NULL)
  165.         xlfail("file not open");
  166.     }
  167.     else if (!consp(arg))
  168.         xlerror("bad argument type",arg);
  169.     }
  170.     return (arg);
  171. }
  172.  
  173. /* xltoomany - report a "too many arguments" error */
  174. xltoomany(args)
  175.   NODE *args;
  176. {
  177.     xlerror("too many arguments",args);
  178. }
  179.  
  180. /* eq - internal eq function */
  181. int eq(arg1,arg2)
  182.   NODE *arg1,*arg2;
  183. {
  184.     return (arg1 == arg2);
  185. }
  186.  
  187. /* eql - internal eql function */
  188. int eql(arg1,arg2)
  189.   NODE *arg1,*arg2;
  190. {
  191.     if (arg1 == arg2)
  192.     return (TRUE);
  193.     else if (fixp(arg1) && fixp(arg2))
  194.     return (arg1->n_int == arg2->n_int);
  195.     else if (floatp(arg1) && floatp(arg2))
  196.     return (arg1->n_float == arg2->n_float);
  197.     else if (stringp(arg1) && stringp(arg2))
  198.     return (strcmp(arg1->n_str,arg2->n_str) == 0);
  199.     else
  200.     return (FALSE);
  201. }
  202.  
  203. /* equal - internal equal function */
  204. int equal(arg1,arg2)
  205.   NODE *arg1,*arg2;
  206. {
  207.     /* compare the arguments */
  208.     if (arg1 == arg2)
  209.     return (TRUE);
  210.     else if (fixp(arg1) && fixp(arg2))
  211.     return (arg1->n_int == arg2->n_int);
  212.     else if (floatp(arg1) && floatp(arg2))
  213.     return (arg1->n_float == arg2->n_float);
  214.     else if (stringp(arg1) && stringp(arg2))
  215.     return (strcmp(arg1->n_str,arg2->n_str) == 0);
  216.     else if (consp(arg1) && consp(arg2))
  217.     return (equal(car(arg1),car(arg2)) && equal(cdr(arg1),cdr(arg2)));
  218.     else
  219.     return (FALSE);
  220. }
  221.