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