home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / xlispsrc / xlmath.c < prev    next >
C/C++ Source or Header  |  1988-02-11  |  10KB  |  418 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 xexp()    { return (unary('E')); } /* exp */
  212. LVAL xsqrt()   { return (unary('R')); } /* sqrt */
  213. LVAL xfix()    { return (unary('I')); } /* truncate */
  214. LVAL xfloat()  { return (unary('F')); } /* float */
  215. LVAL xrand()   { return (unary('?')); } /* random */
  216.  
  217. /* unary - handle unary operations */
  218. LOCAL LVAL unary(fcn)
  219.   int fcn;
  220. {
  221.     FLOTYPE fval;
  222.     FIXTYPE ival;
  223.     LVAL arg;
  224.  
  225.     /* get the argument */
  226.     arg = xlgetarg();
  227.     xllastarg();
  228.  
  229.     /* check its type */
  230.     if (fixp(arg)) {
  231.     ival = getfixnum(arg);
  232.     switch (fcn) {
  233.     case '~':    ival = ~ival; break;
  234.     case 'A':    ival = (ival < 0 ? -ival : ival); break;
  235.     case '+':    ival++; break;
  236.     case '-':    ival--; break;
  237.     case 'I':    break;
  238.     case 'F':    return (cvflonum((FLOTYPE)ival));
  239.     case '?':    ival = (FIXTYPE)osrand((int)ival); break;
  240.     default:    badiop();
  241.     }
  242.     return (cvfixnum(ival));
  243.     }
  244.     else if (floatp(arg)) {
  245.     fval = getflonum(arg);
  246.     switch (fcn) {
  247.     case 'A':    fval = (fval < 0.0 ? -fval : fval); break;
  248.     case '+':    fval += 1.0; break;
  249.     case '-':    fval -= 1.0; break;
  250.     case 'S':    fval = sin(fval); break;
  251.     case 'C':    fval = cos(fval); break;
  252.     case 'T':    fval = tan(fval); break;
  253.     case 'E':    fval = exp(fval); break;
  254.     case 'R':    checkfneg(fval); fval = sqrt(fval); break;
  255.     case 'I':    return (cvfixnum((FIXTYPE)fval));
  256.     case 'F':    break;
  257.     default:    badfop();
  258.     }
  259.     return (cvflonum(fval));
  260.     }
  261.     else
  262.     xlerror("bad argument type",arg);
  263. }
  264.  
  265. /* unary predicates */
  266. LVAL xminusp() { return (predicate('-')); } /* minusp */
  267. LVAL xzerop()  { return (predicate('Z')); } /* zerop */
  268. LVAL xplusp()  { return (predicate('+')); } /* plusp */
  269. LVAL xevenp()  { return (predicate('E')); } /* evenp */
  270. LVAL xoddp()   { return (predicate('O')); } /* oddp */
  271.  
  272. /* predicate - handle a predicate function */
  273. LOCAL LVAL predicate(fcn)
  274.   int fcn;
  275. {
  276.     FLOTYPE fval;
  277.     FIXTYPE ival;
  278.     LVAL arg;
  279.  
  280.     /* get the argument */
  281.     arg = xlgetarg();
  282.     xllastarg();
  283.  
  284.     /* check the argument type */
  285.     if (fixp(arg)) {
  286.     ival = getfixnum(arg);
  287.     switch (fcn) {
  288.     case '-':    ival = (ival < 0); break;
  289.     case 'Z':    ival = (ival == 0); break;
  290.     case '+':    ival = (ival > 0); break;
  291.     case 'E':    ival = ((ival & 1) == 0); break;
  292.     case 'O':    ival = ((ival & 1) != 0); break;
  293.     default:    badiop();
  294.     }
  295.     }
  296.     else if (floatp(arg)) {
  297.     fval = getflonum(arg);
  298.     switch (fcn) {
  299.     case '-':    ival = (fval < 0); break;
  300.     case 'Z':    ival = (fval == 0); break;
  301.     case '+':    ival = (fval > 0); break;
  302.     default:    badfop();
  303.     }
  304.     }
  305.     else
  306.     xlerror("bad argument type",arg);
  307.  
  308.     /* return the result value */
  309.     return (ival ? true : NIL);
  310. }
  311.  
  312. /* comparison functions */
  313. LVAL xlss() { return (compare('<')); } /* < */
  314. LVAL xleq() { return (compare('L')); } /* <= */
  315. LVAL xequ() { return (compare('=')); } /* = */
  316. LVAL xneq() { return (compare('#')); } /* /= */
  317. LVAL xgeq() { return (compare('G')); } /* >= */
  318. LVAL xgtr() { return (compare('>')); } /* > */
  319.  
  320. /* compare - common compare function */
  321. LOCAL LVAL compare(fcn)
  322.   int fcn;
  323. {
  324.     FIXTYPE icmp,ival,iarg;
  325.     FLOTYPE fcmp,fval,farg;
  326.     LVAL arg;
  327.     int mode;
  328.  
  329.     /* get the first argument */
  330.     arg = xlgetarg();
  331.  
  332.     /* set the type of the first argument */
  333.     if (fixp(arg)) {
  334.     ival = getfixnum(arg);
  335.     mode = 'I';
  336.     }
  337.     else if (floatp(arg)) {
  338.     fval = getflonum(arg);
  339.     mode = 'F';
  340.     }
  341.     else
  342.     xlerror("bad argument type",arg);
  343.  
  344.     /* handle each remaining argument */
  345.     for (icmp = TRUE; icmp && moreargs(); ival = iarg, fval = farg) {
  346.  
  347.     /* get the next argument */
  348.     arg = xlgetarg();
  349.  
  350.     /* check its type */
  351.     if (fixp(arg)) {
  352.         switch (mode) {
  353.         case 'I':
  354.             iarg = getfixnum(arg);
  355.             break;
  356.         case 'F':
  357.             farg = (FLOTYPE)getfixnum(arg);
  358.         break;
  359.         }
  360.     }
  361.     else if (floatp(arg)) {
  362.         switch (mode) {
  363.         case 'I':
  364.             fval = (FLOTYPE)ival;
  365.         farg = getflonum(arg);
  366.         mode = 'F';
  367.         break;
  368.         case 'F':
  369.             farg = getflonum(arg);
  370.         break;
  371.         }
  372.     }
  373.     else
  374.         xlerror("bad argument type",arg);
  375.  
  376.     /* compute result of the compare */
  377.     switch (mode) {
  378.     case 'I':
  379.         icmp = ival - iarg;
  380.         switch (fcn) {
  381.         case '<':    icmp = (icmp < 0); break;
  382.         case 'L':    icmp = (icmp <= 0); break;
  383.         case '=':    icmp = (icmp == 0); break;
  384.         case '#':    icmp = (icmp != 0); break;
  385.         case 'G':    icmp = (icmp >= 0); break;
  386.         case '>':    icmp = (icmp > 0); break;
  387.         }
  388.         break;
  389.     case 'F':
  390.         fcmp = fval - farg;
  391.         switch (fcn) {
  392.         case '<':    icmp = (fcmp < 0.0); break;
  393.         case 'L':    icmp = (fcmp <= 0.0); break;
  394.         case '=':    icmp = (fcmp == 0.0); break;
  395.         case '#':    icmp = (fcmp != 0.0); break;
  396.         case 'G':    icmp = (fcmp >= 0.0); break;
  397.         case '>':    icmp = (fcmp > 0.0); break;
  398.         }
  399.         break;
  400.     }
  401.     }
  402.  
  403.     /* return the result */
  404.     return (icmp ? true : NIL);
  405. }
  406.  
  407. /* badiop - bad integer operation */
  408. LOCAL badiop()
  409. {
  410.     xlfail("bad integer operation");
  411. }
  412.  
  413. /* badfop - bad floating point operation */
  414. LOCAL badfop()
  415. {
  416.     xlfail("bad floating point operation");
  417. }
  418.