home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / 32XLISP.ZIP / XLMATH.C < prev    next >
Text File  |  1991-04-28  |  10KB  |  425 lines
  1. /* xlmath - xlisp built-in arithmetic functions */
  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. //#include <math.h>
  8.  
  9. /* external variables */
  10. extern LVAL true;
  11.  
  12. /* forward declarations */
  13. FORWARD LVAL unary();
  14. FORWARD LVAL binary();
  15. FORWARD LVAL predicate();
  16. FORWARD LVAL compare();
  17.  
  18. /* binary functions */
  19. LVAL xadd()    { return (binary('+')); } /* + */
  20. LVAL xsub()    { return (binary('-')); } /* - */
  21. LVAL xmul()    { return (binary('*')); } /* * */
  22. LVAL xdiv()    { return (binary('/')); } /* / */
  23. LVAL xrem()    { return (binary('%')); } /* rem */
  24. LVAL xmin()    { return (binary('m')); } /* min */
  25. LVAL xmax()    { return (binary('M')); } /* max */
  26. LVAL xexpt()   { return (binary('E')); } /* expt */
  27. LVAL xlogand() { return (binary('&')); } /* logand */
  28. LVAL xlogior() { return (binary('|')); } /* logior */
  29. LVAL xlogxor() { return (binary('^')); } /* logxor */
  30.  
  31. /* xgcd - greatest common divisor */
  32. LVAL xgcd()
  33. {
  34.     FIXTYPE m,n,r;
  35.     LVAL arg;
  36.  
  37.     if (!moreargs())            /* check for identity case */
  38.     return (cvfixnum((FIXTYPE)0));
  39.     arg = xlgafixnum();
  40.     n = getfixnum(arg);
  41.     if (n < (FIXTYPE)0) n = -n;        /* absolute value */
  42.     while (moreargs()) {
  43.     arg = xlgafixnum();
  44.     m = getfixnum(arg);
  45.     if (m < (FIXTYPE)0) m = -m;    /* absolute value */
  46.     for (;;) {            /* euclid's algorithm */
  47.         r = m % n;
  48.         if (r == (FIXTYPE)0)
  49.         break;
  50.         m = n;
  51.         n = r;
  52.     }
  53.     }
  54.     return (cvfixnum(n));
  55. }
  56.  
  57. /* binary - handle binary operations */
  58. LOCAL LVAL binary(fcn)
  59.   int fcn;
  60. {
  61.     FIXTYPE ival,iarg;
  62.     FLOTYPE fval,farg;
  63.     LVAL arg;
  64.     int mode;
  65.  
  66.     /* get the first argument */
  67.     arg = xlgetarg();
  68.  
  69.     /* set the type of the first argument */
  70.     if (fixp(arg)) {
  71.     ival = getfixnum(arg);
  72.     mode = 'I';
  73.     }
  74.     else if (floatp(arg)) {
  75.     fval = getflonum(arg);
  76.     mode = 'F';
  77.     }
  78.     else
  79.     xlerror("bad argument type",arg);
  80.  
  81.     /* treat a single argument as a special case */
  82.     if (!moreargs()) {
  83.     switch (fcn) {
  84.     case '-':
  85.         switch (mode) {
  86.         case 'I':
  87.         ival = -ival;
  88.         break;
  89.         case 'F':
  90.         fval = -fval;
  91.         break;
  92.         }
  93.         break;
  94.     case '/':
  95.         switch (mode) {
  96.         case 'I':
  97.         checkizero(ival);
  98.         ival = 1 / ival;
  99.         break;
  100.         case 'F':
  101.         checkfzero(fval);
  102.         fval = 1.0 / fval;
  103.         break;
  104.         }
  105.     }
  106.     }
  107.  
  108.     /* handle each remaining argument */
  109.     while (moreargs()) {
  110.  
  111.     /* get the next argument */
  112.     arg = xlgetarg();
  113.  
  114.     /* check its type */
  115.     if (fixp(arg)) {
  116.         switch (mode) {
  117.         case 'I':
  118.             iarg = getfixnum(arg);
  119.             break;
  120.         case 'F':
  121.             farg = (FLOTYPE)getfixnum(arg);
  122.         break;
  123.         }
  124.     }
  125.     else if (floatp(arg)) {
  126.         switch (mode) {
  127.         case 'I':
  128.             fval = (FLOTYPE)ival;
  129.         farg = getflonum(arg);
  130.         mode = 'F';
  131.         break;
  132.         case 'F':
  133.             farg = getflonum(arg);
  134.         break;
  135.         }
  136.     }
  137.     else
  138.         xlerror("bad argument type",arg);
  139.  
  140.     /* accumulate the result value */
  141.     switch (mode) {
  142.     case 'I':
  143.         switch (fcn) {
  144.         case '+':    ival += iarg; break;
  145.         case '-':    ival -= iarg; break;
  146.         case '*':    ival *= iarg; break;
  147.         case '/':    checkizero(iarg); ival /= iarg; break;
  148.         case '%':    checkizero(iarg); ival %= iarg; break;
  149.         case 'M':    if (iarg > ival) ival = iarg; break;
  150.         case 'm':    if (iarg < ival) ival = iarg; break;
  151.         case '&':    ival &= iarg; break;
  152.         case '|':    ival |= iarg; break;
  153.         case '^':    ival ^= iarg; break;
  154.         default:    badiop();
  155.         }
  156.         break;
  157.     case 'F':
  158.         switch (fcn) {
  159.         case '+':    fval += farg; break;
  160.         case '-':    fval -= farg; break;
  161.         case '*':    fval *= farg; break;
  162.         case '/':    checkfzero(farg); fval /= farg; break;
  163.         case 'M':    if (farg > fval) fval = farg; break;
  164.         case 'm':    if (farg < fval) fval = farg; break;
  165.         case 'E':    fval = pow(fval,farg); break;
  166.         default:    badfop();
  167.         }
  168.             break;
  169.     }
  170.     }
  171.  
  172.     /* return the result */
  173.     switch (mode) {
  174.     case 'I':    return (cvfixnum(ival));
  175.     case 'F':    return (cvflonum(fval));
  176.     }
  177. }
  178.  
  179. /* checkizero - check for integer division by zero */
  180. checkizero(iarg)
  181.   FIXTYPE iarg;
  182. {
  183.     if (iarg == 0)
  184.     xlfail("division by zero");
  185. }
  186.  
  187. /* checkfzero - check for floating point division by zero */
  188. checkfzero(farg)
  189.   FLOTYPE farg;
  190. {
  191.     if (farg == 0.0)
  192.     xlfail("division by zero");
  193. }
  194.  
  195. /* checkfneg - check for square root of a negative number */
  196. checkfneg(farg)
  197.   FLOTYPE farg;
  198. {
  199.     if (farg < 0.0)
  200.     xlfail("square root of a negative number");
  201. }
  202.  
  203. /* unary functions */
  204. LVAL xlognot() { return (unary('~')); } /* lognot */
  205. LVAL xabs()    { return (unary('A')); } /* abs */
  206. LVAL xadd1()   { return (unary('+')); } /* 1+ */
  207. LVAL xsub1()   { return (unary('-')); } /* 1- */
  208. LVAL xsin()    { return (unary('S')); } /* sin */
  209. LVAL xcos()    { return (unary('C')); } /* cos */
  210. LVAL xtan()    { return (unary('T')); } /* tan */
  211. LVAL xasin()   { return (unary('s')); } /* asin */
  212. LVAL xacos()   { return (unary('c')); } /* acos */
  213. LVAL xatan()   { return (unary('t')); } /* atan */
  214. LVAL xexp()    { return (unary('E')); } /* exp */
  215. LVAL xsqrt()   { return (unary('R')); } /* sqrt */
  216. LVAL xfix()    { return (unary('I')); } /* truncate */
  217. LVAL xfloat()  { return (unary('F')); } /* float */
  218. LVAL xrand()   { return (unary('?')); } /* random */
  219.  
  220. /* unary - handle unary operations */
  221. LOCAL LVAL unary(fcn)
  222.   int fcn;
  223. {
  224.     FLOTYPE fval;
  225.     FIXTYPE ival;
  226.     LVAL arg;
  227.  
  228.     /* get the argument */
  229.     arg = xlgetarg();
  230.     xllastarg();
  231.  
  232.     /* check its type */
  233.     if (fixp(arg)) {
  234.     ival = getfixnum(arg);
  235.     switch (fcn) {
  236.     case '~':    ival = ~ival; break;
  237.     case 'A':    ival = (ival < 0 ? -ival : ival); break;
  238.     case '+':    ival++; break;
  239.     case '-':    ival--; break;
  240.     case 'I':    break;
  241.     case 'F':    return (cvflonum((FLOTYPE)ival));
  242.     case '?':    ival = (FIXTYPE)osrand((int)ival); break;
  243.     default:    badiop();
  244.     }
  245.     return (cvfixnum(ival));
  246.     }
  247.     else if (floatp(arg)) {
  248.     fval = getflonum(arg);
  249.     switch (fcn) {
  250.     case 'A':    fval = (fval < 0.0 ? -fval : fval); break;
  251.     case '+':    fval += 1.0; break;
  252.     case '-':    fval -= 1.0; break;
  253.     case 'S':    fval = sin(fval); break;
  254.     case 'C':    fval = cos(fval); break;
  255.     case 'T':    fval = tan(fval); break;
  256.     case 's':    fval = asin(fval); break;
  257.     case 'c':    fval = acos(fval); break;
  258.     case 't':    fval = atan(fval); break;
  259.     case 'E':    fval = exp(fval); break;
  260.     case 'R':    checkfneg(fval); fval = sqrt(fval); break;
  261.     case 'I':    return (cvfixnum((FIXTYPE)fval));
  262.     case 'F':    break;
  263.     default:    badfop();
  264.     }
  265.     return (cvflonum(fval));
  266.     }
  267.     else
  268.     xlerror("bad argument type",arg);
  269. }
  270.  
  271. /* unary predicates */
  272. LVAL xminusp() { return (predicate('-')); } /* minusp */
  273. LVAL xzerop()  { return (predicate('Z')); } /* zerop */
  274. LVAL xplusp()  { return (predicate('+')); } /* plusp */
  275. LVAL xevenp()  { return (predicate('E')); } /* evenp */
  276. LVAL xoddp()   { return (predicate('O')); } /* oddp */
  277.  
  278. /* predicate - handle a predicate function */
  279. LOCAL LVAL predicate(fcn)
  280.   int fcn;
  281. {
  282.     FLOTYPE fval;
  283.     FIXTYPE ival;
  284.     LVAL arg;
  285.  
  286.     /* get the argument */
  287.     arg = xlgetarg();
  288.     xllastarg();
  289.  
  290.     /* check the argument type */
  291.     if (fixp(arg)) {
  292.     ival = getfixnum(arg);
  293.     switch (fcn) {
  294.     case '-':    ival = (ival < 0); break;
  295.     case 'Z':    ival = (ival == 0); break;
  296.     case '+':    ival = (ival > 0); break;
  297.     case 'E':    ival = ((ival & 1) == 0); break;
  298.     case 'O':    ival = ((ival & 1) != 0); break;
  299.     default:    badiop();
  300.     }
  301.     }
  302.     else if (floatp(arg)) {
  303.     fval = getflonum(arg);
  304.     switch (fcn) {
  305.     case '-':    ival = (fval < 0); break;
  306.     case 'Z':    ival = (fval == 0); break;
  307.     case '+':    ival = (fval > 0); break;
  308.     default:    badfop();
  309.     }
  310.     }
  311.     else
  312.     xlerror("bad argument type",arg);
  313.  
  314.     /* return the result value */
  315.     return (ival ? true : NIL);
  316. }
  317.  
  318. /* comparison functions */
  319. LVAL xlss() { return (compare('<')); } /* < */
  320. LVAL xleq() { return (compare('L')); } /* <= */
  321. LVAL xequ() { return (compare('=')); } /* = */
  322. LVAL xneq() { return (compare('#')); } /* /= */
  323. LVAL xgeq() { return (compare('G')); } /* >= */
  324. LVAL xgtr() { return (compare('>')); } /* > */
  325.  
  326. /* compare - common compare function */
  327. LOCAL LVAL compare(fcn)
  328.   int fcn;
  329. {
  330.     FIXTYPE icmp,ival,iarg;
  331.     FLOTYPE fcmp,fval,farg;
  332.     LVAL arg;
  333.     int mode;
  334.  
  335.     /* get the first argument */
  336.     arg = xlgetarg();
  337.  
  338.     /* set the type of the first argument */
  339.     if (fixp(arg)) {
  340.     ival = getfixnum(arg);
  341.     mode = 'I';
  342.     }
  343.     else if (floatp(arg)) {
  344.     fval = getflonum(arg);
  345.     mode = 'F';
  346.     }
  347.     else
  348.     xlerror("bad argument type",arg);
  349.  
  350.     /* handle each remaining argument */
  351.     for (icmp = TRUE; icmp && moreargs(); ival = iarg, fval = farg) {
  352.  
  353.     /* get the next argument */
  354.     arg = xlgetarg();
  355.  
  356.     /* check its type */
  357.     if (fixp(arg)) {
  358.         switch (mode) {
  359.         case 'I':
  360.             iarg = getfixnum(arg);
  361.             break;
  362.         case 'F':
  363.             farg = (FLOTYPE)getfixnum(arg);
  364.         break;
  365.         }
  366.     }
  367.     else if (floatp(arg)) {
  368.         switch (mode) {
  369.         case 'I':
  370.             fval = (FLOTYPE)ival;
  371.         farg = getflonum(arg);
  372.         mode = 'F';
  373.         break;
  374.         case 'F':
  375.             farg = getflonum(arg);
  376.         break;
  377.         }
  378.     }
  379.     else
  380.         xlerror("bad argument type",arg);
  381.  
  382.     /* compute result of the compare */
  383.     switch (mode) {
  384.     case 'I':
  385.         icmp = ival - iarg;
  386.         switch (fcn) {
  387.         case '<':    icmp = (icmp < 0); break;
  388.         case 'L':    icmp = (icmp <= 0); break;
  389.         case '=':    icmp = (icmp == 0); break;
  390.         case '#':    icmp = (icmp != 0); break;
  391.         case 'G':    icmp = (icmp >= 0); break;
  392.         case '>':    icmp = (icmp > 0); break;
  393.         }
  394.         break;
  395.     case 'F':
  396.         fcmp = fval - farg;
  397.         switch (fcn) {
  398.         case '<':    icmp = (fcmp < 0.0); break;
  399.         case 'L':    icmp = (fcmp <= 0.0); break;
  400.         case '=':    icmp = (fcmp == 0.0); break;
  401.         case '#':    icmp = (fcmp != 0.0); break;
  402.         case 'G':    icmp = (fcmp >= 0.0); break;
  403.         case '>':    icmp = (fcmp > 0.0); break;
  404.         }
  405.         break;
  406.     }
  407.     }
  408.  
  409.     /* return the result */
  410.     return (icmp ? true : NIL);
  411. }
  412.  
  413. /* badiop - bad integer operation */
  414. LOCAL badiop()
  415. {
  416.     xlfail("bad integer operation");
  417. }
  418.  
  419. /* badfop - bad floating point operation */
  420. LOCAL badfop()
  421. {
  422.     xlfail("bad floating point operation");
  423. }
  424. 
  425.