home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / windows / c / xlisp21w / sources / xlsubr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-08  |  10.6 KB  |  443 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. extern LVAL true, s_termio, s_stdin, s_stdout;
  11.  
  12. /* xlsubr - define a builtin function */
  13. #ifdef ANSI
  14. LVAL xlsubr(char *sname, int type, LVAL (*fcn)(void),int offset)
  15. #else
  16. LVAL xlsubr(sname,type,fcn,offset)
  17.   char *sname; int type; LVAL (*fcn)(); int offset;
  18. #endif
  19. {
  20.     LVAL sym;
  21.     sym = xlenter(sname);
  22.     setfunction(sym,cvsubr(fcn,type,offset));
  23.     return (sym);
  24. }
  25.  
  26. /* xlgetkeyarg - get a keyword argument */
  27. int xlgetkeyarg(key,pval)
  28.   LVAL key,*pval;
  29. {
  30.     LVAL *argv=xlargv;
  31.     int argc=xlargc;
  32.     for (argv = xlargv, argc = xlargc; (argc -= 2) >= 0; argv += 2) {
  33.         if (*argv == key) {
  34.             *pval = *++argv;
  35.  
  36.             /* delete the used argument */
  37.             if (argc>0) memcpy(argv-1, argv+1, argc*sizeof(LVAL));
  38.             xlargc -=2;
  39.  
  40.             return (TRUE);
  41.         }
  42.     }
  43.     return (FALSE);
  44. }
  45.  
  46. /* xlgkfixnum - get a fixnum keyword argument */
  47. int xlgkfixnum(key,pval)
  48.   LVAL key,*pval;
  49. {
  50.     if (xlgetkeyarg(key,pval)) {
  51.         if (!fixp(*pval))
  52.             xlbadtype(*pval);
  53.         return (TRUE);
  54.     }
  55.     return (FALSE);
  56. }
  57.  
  58. /* xltest - get the :test or :test-not keyword argument */
  59. VOID xltest(pfcn,ptresult)
  60.   LVAL *pfcn; int *ptresult;
  61. {
  62.     if (xlgetkeyarg(k_test,pfcn))       /* :test */
  63.         *ptresult = TRUE;
  64.     else if (xlgetkeyarg(k_tnot,pfcn))  /* :test-not */
  65.         *ptresult = FALSE;
  66.     else {
  67.         *pfcn = getfunction(s_eql);
  68.         *ptresult = TRUE;
  69.     }
  70. }
  71.  
  72. /* xlgetfile - get a file or stream */
  73. LVAL xlgetfile(outflag)
  74.   int outflag;
  75. {
  76.     LVAL arg;
  77.  
  78.     /* get a file or stream (cons) or nil */
  79.     if (null(arg = xlgetarg()))
  80.         return getvalue(outflag ? s_stdout: s_stdin);
  81.     else if (streamp(arg)) {
  82.         if (getfile(arg) == CLOSED)
  83.             xlfail("file not open");
  84.     }
  85.     else if (arg == true)
  86.         return getvalue(s_termio);
  87.     else if (!ustreamp(arg))
  88.         xlbadtype(arg);
  89.     return arg;
  90. }
  91.  
  92. /* xlgetfname - get a filename */
  93. LVAL xlgetfname()
  94. {
  95.     LVAL name;
  96.  
  97.     /* get the next argument */
  98.     name = xlgetarg();
  99.  
  100.     /* get the filename string */
  101. #ifdef FILETABLE
  102.     if (streamp(name) && getfile(name) > CONSOLE)
  103.         /* "Steal" name from file stream */
  104.         name = cvstring(filetab[getfile(name)].tname);
  105.     else
  106. #endif
  107.     if (symbolp(name))
  108.         name = getpname(name);
  109.     else if (!stringp(name))
  110.         xlbadtype(name);
  111.  
  112.     if (getslength(name) >= FNAMEMAX)
  113.         xlerror("file name too long", name);
  114.  
  115.     /* return the name */
  116.     return (name);
  117. }
  118.  
  119. /* needsextension - check if a filename needs an extension */
  120. int needsextension(name)
  121.   char *name;
  122. {
  123.     char *p;
  124.  
  125.     /* check for an extension */
  126.     for (p = &name[strlen(name)]; --p >= &name[0]; )
  127.         if (*p == '.')
  128.             return (FALSE);
  129.         else if (!islower(*p) && !isupper(*p) && !isdigit(*p))
  130.             return (TRUE);
  131.  
  132.     /* no extension found */
  133.     return (TRUE);
  134. }
  135.  
  136. /* xlbadtype - report a "bad argument type" error */
  137. LVAL xlbadtype(arg)
  138.   LVAL arg;
  139. {
  140.     return xlerror("bad argument type",arg);
  141. }
  142.  
  143. /* xltoofew - report a "too few arguments" error */
  144. LVAL xltoofew()
  145. {
  146.     xlfail("too few arguments");
  147.     return (NIL);   /* never returns */
  148. }
  149.  
  150. /* xltoomany - report a "too many arguments" error */
  151. VOID xltoomany()
  152. {
  153.     xlfail("too many arguments");
  154. }
  155.  
  156. /* xltoolong - report a "too long to process" error */
  157. VOID xltoolong()
  158. {
  159.     xlfail("too long to process");
  160. }
  161.  
  162. /* xlnoassign - report a "can't assign/bind to constant" error */
  163. VOID xlnoassign(arg)
  164.    LVAL arg;
  165. {
  166.     xlerror("can't assign/bind to constant", arg);
  167. }
  168.  
  169. #ifdef COMPLX
  170. /* compare floating point for eql and equal */
  171. /* This is by Tom Almy */
  172. #ifdef ANSI
  173. static int XNEAR comparecomplex(LVAL arg1, LVAL arg2)
  174. #else
  175. LOCAL int comparecomplex(arg1, arg2)
  176. LVAL arg1, arg2;
  177. #endif
  178. {
  179.     LVAL r1=getelement(arg1,0), r2=getelement(arg2,0);
  180.     LVAL i1=getelement(arg1,1), i2=getelement(arg2,1);
  181.  
  182.     if (ntype(r1) != ntype(r2)) return FALSE;
  183.     else if (ntype(r1) == FIXNUM)
  184.         return (getfixnum(r1)==getfixnum(r2)&&
  185.                 getfixnum(i1)==getfixnum(i2));
  186.     else
  187.         return (getflonum(r1)==getflonum(r2)&&
  188.                 getflonum(i1)==getflonum(i2));
  189. }
  190.  
  191. #endif
  192.  
  193. /* eql - internal eql function */
  194. int eql(arg1,arg2)
  195.   LVAL arg1,arg2;
  196. {
  197.     /* compare the arguments */
  198.     if (arg1 == arg2)
  199.         return (TRUE);
  200.     else if (arg1 != NIL) {
  201.         switch (ntype(arg1)) {
  202.         case FIXNUM:
  203.             return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
  204.         case FLONUM:
  205.             return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
  206. #ifdef COMPLX
  207.         case COMPLEX:
  208.             return (complexp(arg2) ? comparecomplex(arg1,arg2) : FALSE);
  209. #endif
  210.         default:
  211.             return (FALSE);
  212.         }
  213.     }
  214.     else
  215.         return (FALSE);
  216. }
  217.  
  218. #ifdef ANSI
  219. static int XNEAR stringcmp(LVAL arg1, LVAL arg2)
  220. #else
  221. LOCAL stringcmp(arg1, arg2)         /* compare two strings for equal */
  222. LVAL arg1, arg2;                    /* Written by TAA. Compares strings */
  223.                                     /* with embedded nulls */
  224. #endif
  225. {
  226.     char XFAR *s1 = getstring(arg1), XFAR *s2 = getstring(arg2);
  227.     unsigned l = getslength(arg1);
  228.  
  229.     if (l != getslength(arg2)) return FALSE;
  230.  
  231.     while (l-- > 0) if (*s1++ != *s2++) return FALSE;
  232.  
  233.     return TRUE;
  234. }
  235.  
  236. /* equal- internal equal function */
  237. int equal(arg1,arg2)
  238.   LVAL arg1,arg2;
  239. {
  240.     /* compare the arguments */
  241. isItEqual:  /* turn tail recursion into iteration */
  242.     if (arg1 == arg2)
  243.         return (TRUE);
  244.     else if (arg1 != NIL) {
  245.         switch (ntype(arg1)) {
  246.         case FIXNUM:
  247.             return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
  248.         case FLONUM:
  249.             return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
  250. #ifdef COMPLX
  251.         case COMPLEX:
  252.             return (complexp(arg2) ? comparecomplex(arg1,arg2) : FALSE);
  253. #endif
  254.         case STRING:
  255.             return (stringp(arg2) ? stringcmp(arg1,arg2) : FALSE); /* TAA MOD */
  256.         case CONS:  /* TAA MOD turns tail recursion into iteration */
  257.                     /* Not only is this faster, but greatly reduces chance */
  258.                     /* of stack overflow */
  259.             if (consp(arg2) && equal(car(arg1),car(arg2))) {
  260.                 arg1 = cdr(arg1);
  261.                 arg2 = cdr(arg2);
  262.                 goto isItEqual;
  263.             }
  264.             return FALSE;
  265.         default:
  266.             return (FALSE);
  267.         }
  268.     }
  269.     else
  270.         return (FALSE);
  271. }
  272.  
  273.  
  274. #ifdef KEYARG
  275. /* TAA Addition */
  276. /* xlkey - get the :key keyword argument */
  277. extern LVAL k_key;
  278.  
  279. LVAL xlkey()
  280. {
  281.     LVAL kfcn;
  282.  
  283.     if (xlgetkeyarg(k_key,&kfcn)) return kfcn;
  284.     return NIL;
  285. }
  286.  
  287. /* xlapp1 - apply a function of a single argument */
  288. LVAL xlapp1(fun,arg)
  289.   LVAL fun,arg;
  290. {
  291.     FRAMEP newfp;
  292.  
  293.     /* create the new call frame */
  294.     newfp = xlsp;
  295.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  296.     pusharg(fun);
  297.     pusharg(cvfixnum((FIXTYPE)1));
  298.     pusharg(arg);
  299.     xlfp = newfp;
  300.  
  301.     /* return the result of applying the function */
  302.     return xlapply(1);
  303.  
  304. }
  305.  
  306.  
  307. /* dotest1 - call a test function with one argument */
  308. int dotest1(arg,fun,kfun)
  309.   LVAL arg,fun,kfun;
  310. {
  311.     FRAMEP newfp;
  312.  
  313.     if (kfun != NIL) arg = xlapp1(kfun,arg);
  314.  
  315.     /* create the new call frame */
  316.     newfp = xlsp;
  317.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  318.     pusharg(fun);
  319.     pusharg(cvfixnum((FIXTYPE)1));
  320.     pusharg(arg);
  321.     xlfp = newfp;
  322.  
  323.     /* return the result of applying the test function */
  324.     return (xlapply(1) != NIL);
  325.  
  326. }
  327.  
  328. /* dotest2 - call a test function with two arguments */
  329. int dotest2(arg1,arg2,fun,kfun)
  330.   LVAL arg1,arg2,fun,kfun;
  331. {
  332.     FRAMEP newfp;
  333.  
  334.     if (kfun != NIL) arg2 = xlapp1(kfun,arg2);
  335.  
  336.     /* Speedup for default case TAA MOD */
  337.     if (fun == getfunction(s_eql))
  338.         return (eql(arg1,arg2));
  339.  
  340.     /* create the new call frame */
  341.     newfp = xlsp;
  342.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  343.     pusharg(fun);
  344.     pusharg(cvfixnum((FIXTYPE)2));
  345.     pusharg(arg1);
  346.     pusharg(arg2);
  347.     xlfp = newfp;
  348.  
  349.     /* return the result of applying the test function */
  350.     return (xlapply(2) != NIL);
  351.  
  352. }
  353.  
  354. /* dotest2s - call a test function with two arguments, symmetrical */
  355. int dotest2s(arg1,arg2,fun,kfun)
  356.   LVAL arg1,arg2,fun,kfun;
  357. {
  358.     FRAMEP newfp;
  359.  
  360.     if (kfun != NIL) {
  361.         arg1 = xlapp1(kfun,arg1);
  362.         arg2 = xlapp1(kfun,arg2);
  363.     }
  364.  
  365.     /* Speedup for default case TAA MOD */
  366.     if (fun == getfunction(s_eql))
  367.         return (eql(arg1,arg2));
  368.  
  369.     /* create the new call frame */
  370.     newfp = xlsp;
  371.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  372.     pusharg(fun);
  373.     pusharg(cvfixnum((FIXTYPE)2));
  374.     pusharg(arg1);
  375.     pusharg(arg2);
  376.     xlfp = newfp;
  377.  
  378.     /* return the result of applying the test function */
  379.     return (xlapply(2) != NIL);
  380.  
  381. }
  382.  
  383. #else
  384. /* dotest1 - call a test function with one argument */
  385. int dotest1(arg,fun)
  386.   LVAL arg,fun;
  387. {
  388.     FRAMEP newfp;
  389.  
  390.     /* create the new call frame */
  391.     newfp = xlsp;
  392.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  393.     pusharg(fun);
  394.     pusharg(cvfixnum((FIXTYPE)1));
  395.     pusharg(arg);
  396.     xlfp = newfp;
  397.  
  398.     /* return the result of applying the test function */
  399.     return (xlapply(1) != NIL);
  400.  
  401. }
  402.  
  403. /* dotest2 - call a test function with two arguments */
  404. int dotest2(arg1,arg2,fun)
  405.   LVAL arg1,arg2,fun;
  406. {
  407.     FRAMEP newfp;
  408.  
  409.     /* Speedup for default case TAA MOD */
  410.     if (fun == getfunction(s_eql))
  411.         return (eql(arg1,arg2));
  412.  
  413.     /* create the new call frame */
  414.     newfp = xlsp;
  415.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  416.     pusharg(fun);
  417.     pusharg(cvfixnum((FIXTYPE)2));
  418.     pusharg(arg1);
  419.     pusharg(arg2);
  420.     xlfp = newfp;
  421.  
  422.     /* return the result of applying the test function */
  423.     return (xlapply(2) != NIL);
  424.  
  425. }
  426.  
  427. #endif
  428.  
  429. #ifdef COMPLX
  430. /* return value of a number coerced to a FLOTYPE */
  431. FLOTYPE makefloat(x)
  432.      LVAL x;
  433. {
  434.     if (fixp(x)) return ((FLOTYPE) getfixnum(x));
  435.     else if (floatp(x)) return getflonum(x);
  436. #ifdef RATIOS
  437.     else if (ratiop(x)) return (getnumer(x)/(FLOTYPE)getdenom(x));
  438. #endif
  439.     xlerror("not a number", x);
  440.     return 0.0; /* never reached */
  441. }
  442. #endif
  443.