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