home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / xlispplu / xlisp2tc / xlsubr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-03-25  |  4.1 KB  |  191 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 LVAL k_test,k_tnot,s_eql;
  10.  
  11. /* xlsubr - define a builtin function */
  12. LVAL xlsubr(sname,type,fcn,offset)
  13.   char *sname; int type; LVAL (*fcn)(); int offset;
  14. {
  15.     LVAL sym;
  16.     sym = xlenter(sname);
  17.     setfunction(sym,cvsubr(fcn,type,offset));
  18.     return (sym);
  19. }
  20.  
  21. /* xlgetkeyarg - get a keyword argument */
  22. int xlgetkeyarg(key,pval)
  23.   LVAL key,*pval;
  24. {
  25.     LVAL *argv=xlargv;
  26.     int argc=xlargc;
  27.     for (argv = xlargv, argc = xlargc; (argc -= 2) >= 0; argv += 2) {
  28.     if (*argv == key) {
  29.         *pval = *++argv;
  30.         return (TRUE);
  31.     }
  32.     }
  33.     return (FALSE);
  34. }
  35.  
  36. /* xlgkfixnum - get a fixnum keyword argument */
  37. int xlgkfixnum(key,pval)
  38.   LVAL key,*pval;
  39. {
  40.     if (xlgetkeyarg(key,pval)) {
  41.     if (!fixp(*pval))
  42.         xlbadtype(*pval);
  43.     return (TRUE);
  44.     }
  45.     return (FALSE);
  46. }
  47.  
  48. /* xltest - get the :test or :test-not keyword argument */
  49. void xltest(pfcn,ptresult)
  50.   LVAL *pfcn; int *ptresult;
  51. {
  52.     if (xlgetkeyarg(k_test,pfcn))    /* :test */
  53.     *ptresult = TRUE;
  54.     else if (xlgetkeyarg(k_tnot,pfcn))    /* :test-not */
  55.     *ptresult = FALSE;
  56.     else {
  57.     *pfcn = getfunction(s_eql);
  58.     *ptresult = TRUE;
  59.     }
  60. }
  61.  
  62. /* xlgetfile - get a file or stream */
  63. LVAL xlgetfile()
  64. {
  65.     LVAL arg;
  66.  
  67.     /* get a file or stream (cons) or nil */
  68.     if (arg = xlgetarg()) {
  69.     if (streamp(arg)) {
  70.         if (getfile(arg) == NULL)
  71.         xlfail("file not open");
  72.     }
  73.     else if (!ustreamp(arg))
  74.         xlerror("bad argument type",arg);
  75.     }
  76.     return (arg);
  77. }
  78.  
  79. /* xlgetfname - get a filename */
  80. LVAL xlgetfname()
  81. {
  82.     LVAL name;
  83.  
  84.     /* get the next argument */
  85.     name = xlgetarg();
  86.  
  87.     /* get the filename string */
  88.     if (symbolp(name))
  89.     name = getpname(name);
  90.     else if (!stringp(name))
  91.     xlerror("bad argument type",name);
  92.  
  93.     /* return the name */
  94.     return (name);
  95. }
  96.  
  97. /* needsextension - check if a filename needs an extension */
  98. int needsextension(name)
  99.   char *name;
  100. {
  101.     char *p;
  102.  
  103.     /* check for an extension */
  104.     for (p = &name[strlen(name)]; --p >= &name[0]; )
  105.     if (*p == '.')
  106.         return (FALSE);
  107.     else if (!islower(*p) && !isupper(*p) && !isdigit(*p))
  108.         return (TRUE);
  109.  
  110.     /* no extension found */
  111.     return (TRUE);
  112. }
  113.  
  114. /* xlbadtype - report a "bad argument type" error */
  115. LVAL xlbadtype(arg)
  116.   LVAL arg;
  117. {
  118.     xlerror("bad argument type",arg);
  119.     /* keep LINT happy */
  120.     return (NIL) ;
  121. }
  122.  
  123. /* xltoofew - report a "too few arguments" error */
  124. LVAL xltoofew()
  125. {
  126.     xlfail("too few arguments");
  127.     /* keep LINT happy */
  128.     return (NIL) ;
  129. }
  130.  
  131. /* xltoomany - report a "too many arguments" error */
  132. void xltoomany()
  133. {
  134.     xlfail("too many arguments");
  135. }
  136.  
  137. /* eq - internal eq function */
  138. int eq(arg1,arg2)
  139.   LVAL arg1,arg2;
  140. {
  141.     return (arg1 == arg2);
  142. }
  143.  
  144. /* eql - internal eql function */
  145. int eql(arg1,arg2)
  146.   LVAL arg1,arg2;
  147. {
  148.     /* compare the arguments */
  149.     if (arg1 == arg2)
  150.     return (TRUE);
  151.     else if (arg1) {
  152.     switch (ntype(arg1)) {
  153.     case FIXNUM:
  154.         return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
  155.     case FLONUM:
  156.         return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
  157.     default:
  158.         return (FALSE);
  159.     }
  160.     }
  161.     else
  162.     return (FALSE);
  163. }
  164.  
  165. /* equal - internal equal function */
  166. int equal(arg1,arg2)
  167.   LVAL arg1,arg2;
  168. {
  169.     /* compare the arguments */
  170.     if (arg1 == arg2)
  171.     return (TRUE);
  172.     else if (arg1) {
  173.     switch (ntype(arg1)) {
  174.     case FIXNUM:
  175.         return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
  176.     case FLONUM:
  177.         return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
  178.     case STRING:
  179.         return (stringp(arg2) ? strcmp(getstring(arg1),
  180.                        getstring(arg2)) == 0 : FALSE);
  181.     case CONS:
  182.         return (consp(arg2) ? equal(car(arg1),car(arg2))
  183.                    && equal(cdr(arg1),cdr(arg2)) : FALSE);
  184.     default:
  185.         return (FALSE);
  186.     }
  187.     }
  188.     else
  189.     return (FALSE);
  190. }
  191.