home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / drdobbs / 1991 / 08 / xscheme / xsmath.c < prev    next >
Text File  |  1991-05-14  |  15KB  |  622 lines
  1. /* xsmath.c - xscheme built-in arithmetic functions */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7. #include <math.h>
  8.  
  9. /* external variables */
  10. extern LVAL true;
  11.  
  12. /* forward declarations */
  13. #ifdef __STDC__
  14. static LVAL binary(int fcn);
  15. static LVAL unary(int fcn);
  16. static LVAL predicate(int fcn);
  17. static LVAL compare(int fcn);
  18. static FLOTYPE toflotype(LVAL val);
  19. static void checkizero(FIXTYPE iarg);
  20. static void checkineg(FIXTYPE iarg);
  21. static void checkfzero(FLOTYPE farg);
  22. static void checkfneg(FLOTYPE farg);
  23. static void badiop(void);
  24. static void badfop(void);
  25. #else
  26. static LVAL unary();
  27. static LVAL binary();
  28. static LVAL predicate();
  29. static LVAL compare();
  30. static FLOTYPE toflotype();
  31. #endif
  32.  
  33. /* xexactp - built-in function 'exact?' */
  34. /**** THIS IS REALLY JUST A STUB FOR NOW ****/
  35. LVAL xexactp()
  36. {
  37.     (void)xlganumber();
  38.     xllastarg();
  39.     return (NIL);
  40. }
  41.  
  42. /* xinexactp - built-in function 'inexact?' */
  43. /**** THIS IS REALLY JUST A STUB FOR NOW ****/
  44. LVAL xinexactp()
  45. {
  46.     (void)xlganumber();
  47.     xllastarg();
  48.     return (true);
  49. }
  50.  
  51. /* xatan - built-in function 'atan' */
  52. LVAL xatan()
  53. {
  54.     LVAL arg,arg2;
  55.     FLOTYPE val;
  56.     
  57.     /* get the first argument */
  58.     arg = xlganumber();
  59.     
  60.     /* handle two argument (atan y x) */
  61.     if (moreargs()) {
  62.     arg2 = xlganumber();
  63.     xllastarg();
  64.     val = atan2(toflotype(arg),toflotype(arg2));
  65.     }
  66.     
  67.     /* handle one argument (atan x) */
  68.     else
  69.     val = atan(toflotype(arg));
  70.  
  71.     /* return the resulting flonum */
  72.     return (cvflonum(val));
  73. }
  74.  
  75. /* xfloor - built-in function 'floor' */
  76. LVAL xfloor()
  77. {
  78.     LVAL arg;
  79.  
  80.     /* get the argument */
  81.     arg = xlgetarg();
  82.     xllastarg();
  83.  
  84.     /* check its type */
  85.     if (fixp(arg))
  86.     return (arg);
  87.     else if (floatp(arg))
  88.     return (cvfixnum((FIXTYPE)floor(getflonum(arg))));
  89.     xlbadtype(arg);
  90.     return (NIL); /* never reached */
  91. }
  92.  
  93. /* xceiling - built-in function 'ceiling' */
  94. LVAL xceiling()
  95. {
  96.     LVAL arg;
  97.  
  98.     /* get the argument */
  99.     arg = xlgetarg();
  100.     xllastarg();
  101.  
  102.     /* check its type */
  103.     if (fixp(arg))
  104.     return (arg);
  105.     else if (floatp(arg))
  106.     return (cvfixnum((FIXTYPE)ceil(getflonum(arg))));
  107.     xlbadtype(arg);
  108.     return (NIL); /* never reached */
  109. }
  110.  
  111. /* xround - built-in function 'round' */
  112. LVAL xround()
  113. {
  114.     FLOTYPE x,y,z;
  115.     LVAL arg;
  116.  
  117.     /* get the argument */
  118.     arg = xlgetarg();
  119.     xllastarg();
  120.  
  121.     /* check its type */
  122.     if (fixp(arg))
  123.     return (arg);
  124.     else if (floatp(arg)) {
  125.     x = getflonum(arg);
  126.     y = floor(x);
  127.     z = x - y;
  128.     if (z == 0.5) {
  129.         if (((FIXTYPE)y & 1) == 1)
  130.         y += 1.0;
  131.         return (cvfixnum((FIXTYPE)y));
  132.     }
  133.     else if (z < 0.5)
  134.         return (cvfixnum((FIXTYPE)y));
  135.     else
  136.         return (cvfixnum((FIXTYPE)(y + 1.0)));
  137.     }
  138.     xlbadtype(arg);
  139.     return (NIL); /* never reached */
  140. }
  141.  
  142. /* xtruncate - built-in function 'truncate' */
  143. LVAL xtruncate()
  144. {
  145.     LVAL arg;
  146.  
  147.     /* get the argument */
  148.     arg = xlgetarg();
  149.     xllastarg();
  150.  
  151.     /* check its type */
  152.     if (fixp(arg))
  153.     return (arg);
  154.     else if (floatp(arg))
  155.     return (cvfixnum((FIXTYPE)(getflonum(arg))));
  156.     xlbadtype(arg);
  157.     return (NIL); /* never reached */
  158. }
  159.  
  160. /* binary functions */
  161. LVAL xadd()                /* + */
  162. {
  163.     if (!moreargs())
  164.     return (cvfixnum((FIXTYPE)0));
  165.     return (binary('+'));
  166. }
  167. LVAL xmul()                /* * */
  168. {
  169.     if (!moreargs())
  170.     return (cvfixnum((FIXTYPE)1));
  171.     return (binary('*'));
  172. }
  173. LVAL xsub()    { return (binary('-')); } /* - */
  174. LVAL xdiv()    { return (binary('/')); } /* / */
  175. LVAL xquo()    { return (binary('Q')); } /* quotient */
  176. LVAL xrem()    { return (binary('R')); } /* remainder */
  177. LVAL xmin()    { return (binary('m')); } /* min */
  178. LVAL xmax()    { return (binary('M')); } /* max */
  179. LVAL xexpt()   { return (binary('E')); } /* expt */
  180. LVAL xlogand() { return (binary('&')); } /* logand */
  181. LVAL xlogior() { return (binary('|')); } /* logior */
  182. LVAL xlogxor() { return (binary('^')); } /* logxor */
  183.  
  184. /* binary - handle binary operations */
  185. static LVAL binary(fcn)
  186.   int fcn;
  187. {
  188.     FIXTYPE ival,iarg;
  189.     FLOTYPE fval,farg;
  190.     LVAL arg;
  191.     int mode;
  192.  
  193.     /* get the first argument */
  194.     arg = xlgetarg();
  195.  
  196.     /* set the type of the first argument */
  197.     if (fixp(arg)) {
  198.     ival = getfixnum(arg);
  199.     mode = 'I';
  200.     }
  201.     else if (floatp(arg)) {
  202.     fval = getflonum(arg);
  203.     mode = 'F';
  204.     }
  205.     else
  206.     xlbadtype(arg);
  207.  
  208.     /* treat a single argument as a special case */
  209.     if (!moreargs()) {
  210.     switch (fcn) {
  211.     case '-':
  212.         switch (mode) {
  213.         case 'I':
  214.         ival = -ival;
  215.         break;
  216.         case 'F':
  217.         fval = -fval;
  218.         break;
  219.         }
  220.         break;
  221.     case '/':
  222.         switch (mode) {
  223.         case 'I':
  224.         checkizero(ival);
  225.         if (ival != 1) {
  226.             fval = 1.0 / (FLOTYPE)ival;
  227.             mode = 'F';
  228.         }
  229.         break;
  230.         case 'F':
  231.         checkfzero(fval);
  232.         fval = 1.0 / fval;
  233.         break;
  234.         }
  235.     }
  236.     }
  237.  
  238.     /* handle each remaining argument */
  239.     while (moreargs()) {
  240.  
  241.     /* get the next argument */
  242.     arg = xlgetarg();
  243.  
  244.     /* check its type */
  245.     if (fixp(arg)) {
  246.         switch (mode) {
  247.         case 'I':
  248.             iarg = getfixnum(arg);
  249.             break;
  250.         case 'F':
  251.             farg = (FLOTYPE)getfixnum(arg);
  252.         break;
  253.         }
  254.     }
  255.     else if (floatp(arg)) {
  256.         switch (mode) {
  257.         case 'I':
  258.             fval = (FLOTYPE)ival;
  259.         farg = getflonum(arg);
  260.         mode = 'F';
  261.         break;
  262.         case 'F':
  263.             farg = getflonum(arg);
  264.         break;
  265.         }
  266.     }
  267.     else
  268.         xlbadtype(arg);
  269.  
  270.     /* accumulate the result value */
  271.     switch (mode) {
  272.     case 'I':
  273.         switch (fcn) {
  274.         case '+':    ival += iarg; break;
  275.         case '-':    ival -= iarg; break;
  276.         case '*':    ival *= iarg; break;
  277.         case '/':    checkizero(iarg);
  278.             if ((ival % iarg) == 0)        
  279.                 ival /= iarg;
  280.             else {
  281.                 fval = (FLOTYPE)ival;
  282.                 farg = (FLOTYPE)iarg;
  283.                 fval /= farg;
  284.                 mode = 'F';
  285.             }
  286.             break;
  287.         case 'Q':    checkizero(iarg); ival /= iarg; break;
  288.         case 'R':    checkizero(iarg); ival %= iarg; break;
  289.         case 'M':    if (iarg > ival) ival = iarg; break;
  290.         case 'm':    if (iarg < ival) ival = iarg; break;
  291.         case 'E':    return (cvflonum((FLOTYPE)pow((FLOTYPE)ival,(FLOTYPE)iarg)));
  292.         case '&':    ival &= iarg; break;
  293.         case '|':    ival |= iarg; break;
  294.         case '^':    ival ^= iarg; break;
  295.         default:    badiop();
  296.         }
  297.         break;
  298.     case 'F':
  299.         switch (fcn) {
  300.         case '+':    fval += farg; break;
  301.         case '-':    fval -= farg; break;
  302.         case '*':    fval *= farg; break;
  303.         case '/':    checkfzero(farg); fval /= farg; break;
  304.         case 'M':    if (farg > fval) fval = farg; break;
  305.         case 'm':    if (farg < fval) fval = farg; break;
  306.         case 'E':    fval = pow(fval,farg); break;
  307.         default:    badfop();
  308.         }
  309.             break;
  310.     }
  311.     }
  312.  
  313.     /* return the result */
  314.     switch (mode) {
  315.     case 'I':    return (cvfixnum(ival));
  316.     case 'F':    return (cvflonum(fval));
  317.     }
  318.     return (NIL); /* never reached */
  319. }
  320.  
  321. /* unary functions */
  322. LVAL xlognot() { return (unary('~')); } /* lognot */
  323. LVAL xabs()      { return (unary('A')); } /* abs */
  324. LVAL xadd1()     { return (unary('+')); } /* 1+ */
  325. LVAL xsub1()     { return (unary('-')); } /* -1+ */
  326. LVAL xsin()      { return (unary('S')); } /* sin */
  327. LVAL xcos()      { return (unary('C')); } /* cos */
  328. LVAL xtan()      { return (unary('T')); } /* tan */
  329. LVAL xasin()     { return (unary('s')); } /* asin */
  330. LVAL xacos()     { return (unary('c')); } /* acos */
  331. LVAL xxexp()     { return (unary('E')); } /* exp */
  332. LVAL xsqrt()     { return (unary('R')); } /* sqrt */
  333. LVAL xxlog()     { return (unary('L')); } /* log */
  334. LVAL xrandom()   { return (unary('?')); } /* random */
  335.  
  336. /* unary - handle unary operations */
  337. static LVAL unary(fcn)
  338.   int fcn;
  339. {
  340.     FLOTYPE fval;
  341.     FIXTYPE ival;
  342.     LVAL arg;
  343.  
  344.     /* get the argument */
  345.     arg = xlgetarg();
  346.     xllastarg();
  347.  
  348.     /* check its type */
  349.     if (fixp(arg)) {
  350.     ival = getfixnum(arg);
  351.     switch (fcn) {
  352.     case '~':    ival = ~ival; break;
  353.     case 'A':    ival = (ival < 0 ? -ival : ival); break;
  354.     case '+':    ival++; break;
  355.     case '-':    ival--; break;
  356.     case 'S':    return (cvflonum((FLOTYPE)sin((FLOTYPE)ival)));
  357.     case 'C':    return (cvflonum((FLOTYPE)cos((FLOTYPE)ival)));
  358.     case 'T':    return (cvflonum((FLOTYPE)tan((FLOTYPE)ival)));
  359.     case 's':    return (cvflonum((FLOTYPE)asin((FLOTYPE)ival)));
  360.     case 'c':    return (cvflonum((FLOTYPE)acos((FLOTYPE)ival)));
  361.     case 't':    return (cvflonum((FLOTYPE)atan((FLOTYPE)ival)));
  362.     case 'E':    return (cvflonum((FLOTYPE)exp((FLOTYPE)ival)));
  363.     case 'L':    return (cvflonum((FLOTYPE)log((FLOTYPE)ival)));
  364.     case 'R':    checkineg(ival);
  365.             return (cvflonum((FLOTYPE)sqrt((FLOTYPE)ival)));
  366.     case '?':    ival = (FIXTYPE)osrand((int)ival); break;
  367.     default:    badiop();
  368.     }
  369.     return (cvfixnum(ival));
  370.     }
  371.     else if (floatp(arg)) {
  372.     fval = getflonum(arg);
  373.     switch (fcn) {
  374.     case 'A':    fval = (fval < 0.0 ? -fval : fval); break;
  375.     case '+':    fval += 1.0; break;
  376.     case '-':    fval -= 1.0; break;
  377.     case 'S':    fval = sin(fval); break;
  378.     case 'C':    fval = cos(fval); break;
  379.     case 'T':    fval = tan(fval); break;
  380.     case 's':    fval = asin(fval); break;
  381.     case 'c':    fval = acos(fval); break;
  382.     case 't':    fval = atan(fval); break;
  383.     case 'E':    fval = exp(fval); break;
  384.     case 'L':    fval = log(fval); break;
  385.     case 'R':    checkfneg(fval);
  386.             fval = sqrt(fval); break;
  387.     default:    badfop();
  388.     }
  389.     return (cvflonum(fval));
  390.     }
  391.     xlbadtype(arg);
  392.     return (NIL); /* never reached */
  393. }
  394.  
  395. /* xgcd - greatest common divisor */
  396. LVAL xgcd()
  397. {
  398.     FIXTYPE m,n,r;
  399.     LVAL arg;
  400.  
  401.     if (!moreargs())            /* check for identity case */
  402.     return (cvfixnum((FIXTYPE)0));
  403.     arg = xlgafixnum();
  404.     n = getfixnum(arg);
  405.     if (n < (FIXTYPE)0) n = -n;        /* absolute value */
  406.     while (moreargs()) {
  407.     arg = xlgafixnum();
  408.     m = getfixnum(arg);
  409.     if (m < (FIXTYPE)0) m = -m;    /* absolute value */
  410.     for (;;) {            /* euclid's algorithm */
  411.         r = m % n;
  412.         if (r == (FIXTYPE)0)
  413.         break;
  414.         m = n;
  415.         n = r;
  416.     }
  417.     }
  418.     return (cvfixnum(n));
  419. }
  420.  
  421. /* unary predicates */
  422. LVAL xnegativep() { return (predicate('-')); } /* negative? */
  423. LVAL xzerop()     { return (predicate('Z')); } /* zero? */
  424. LVAL xpositivep() { return (predicate('+')); } /* positive? */
  425. LVAL xevenp()     { return (predicate('E')); } /* even? */
  426. LVAL xoddp()      { return (predicate('O')); } /* odd? */
  427.  
  428. /* predicate - handle a predicate function */
  429. static LVAL predicate(fcn)
  430.   int fcn;
  431. {
  432.     FLOTYPE fval;
  433.     FIXTYPE ival;
  434.     LVAL arg;
  435.  
  436.     /* get the argument */
  437.     arg = xlgetarg();
  438.     xllastarg();
  439.  
  440.     /* check the argument type */
  441.     if (fixp(arg)) {
  442.     ival = getfixnum(arg);
  443.     switch (fcn) {
  444.     case '-':    ival = (ival < 0); break;
  445.     case 'Z':    ival = (ival == 0); break;
  446.     case '+':    ival = (ival > 0); break;
  447.     case 'E':    ival = ((ival & 1) == 0); break;
  448.     case 'O':    ival = ((ival & 1) != 0); break;
  449.     default:    badiop();
  450.     }
  451.     }
  452.     else if (floatp(arg)) {
  453.     fval = getflonum(arg);
  454.     switch (fcn) {
  455.     case '-':    ival = (fval < 0); break;
  456.     case 'Z':    ival = (fval == 0); break;
  457.     case '+':    ival = (fval > 0); break;
  458.     default:    badfop();
  459.     }
  460.     }
  461.     else
  462.     xlbadtype(arg);
  463.  
  464.     /* return the result value */
  465.     return (ival ? true : NIL);
  466. }
  467.  
  468. /* comparison functions */
  469. LVAL xlss() { return (compare('<')); } /* < */
  470. LVAL xleq() { return (compare('L')); } /* <= */
  471. LVAL xeql() { return (compare('=')); } /* = */
  472. LVAL xgeq() { return (compare('G')); } /* >= */
  473. LVAL xgtr() { return (compare('>')); } /* > */
  474.  
  475. /* compare - common compare function */
  476. static LVAL compare(fcn)
  477.   int fcn;
  478. {
  479.     FIXTYPE icmp,ival,iarg;
  480.     FLOTYPE fcmp,fval,farg;
  481.     LVAL arg;
  482.     int mode;
  483.  
  484.     /* get the first argument */
  485.     arg = xlgetarg();
  486.  
  487.     /* set the type of the first argument */
  488.     if (fixp(arg)) {
  489.     ival = getfixnum(arg);
  490.     mode = 'I';
  491.     }
  492.     else if (floatp(arg)) {
  493.     fval = getflonum(arg);
  494.     mode = 'F';
  495.     }
  496.     else
  497.     xlbadtype(arg);
  498.  
  499.     /* handle each remaining argument */
  500.     for (icmp = TRUE; icmp && moreargs(); ) {
  501.  
  502.     /* get the next argument */
  503.     arg = xlgetarg();
  504.  
  505.     /* check its type */
  506.     if (fixp(arg)) {
  507.         switch (mode) {
  508.         case 'I':
  509.             iarg = getfixnum(arg);
  510.             break;
  511.         case 'F':
  512.             farg = (FLOTYPE)getfixnum(arg);
  513.         break;
  514.         }
  515.     }
  516.     else if (floatp(arg)) {
  517.         switch (mode) {
  518.         case 'I':
  519.             fval = (FLOTYPE)ival;
  520.         farg = getflonum(arg);
  521.         mode = 'F';
  522.         break;
  523.         case 'F':
  524.             farg = getflonum(arg);
  525.         break;
  526.         }
  527.     }
  528.     else
  529.         xlbadtype(arg);
  530.  
  531.     /* compute result of the compare */
  532.     switch (mode) {
  533.     case 'I':
  534.         icmp = ival - iarg;
  535.         switch (fcn) {
  536.         case '<':    icmp = (icmp < 0); break;
  537.         case 'L':    icmp = (icmp <= 0); break;
  538.         case '=':    icmp = (icmp == 0); break;
  539.         case 'G':    icmp = (icmp >= 0); break;
  540.         case '>':    icmp = (icmp > 0); break;
  541.         }
  542.         break;
  543.     case 'F':
  544.         fcmp = fval - farg;
  545.         switch (fcn) {
  546.         case '<':    icmp = (fcmp < 0.0); break;
  547.         case 'L':    icmp = (fcmp <= 0.0); break;
  548.         case '=':    icmp = (fcmp == 0.0); break;
  549.         case 'G':    icmp = (fcmp >= 0.0); break;
  550.         case '>':    icmp = (fcmp > 0.0); break;
  551.         }
  552.         break;
  553.     }
  554.  
  555.     /* update the values */
  556.     ival = iarg;
  557.     fval = farg;
  558.     }
  559.  
  560.     /* get rid of extra arguments */
  561.     if (moreargs()) xlpoprest();
  562.  
  563.     /* return the result */
  564.     return (icmp ? true : NIL);
  565. }
  566.  
  567. /* toflotype - convert a lisp value to a floating point number */
  568. FLOTYPE toflotype(val)
  569.   LVAL val;
  570. {
  571.     /* must be a number for this to work */
  572.     switch (ntype(val)) {
  573.     case FIXNUM:    return ((FLOTYPE)getfixnum(val));
  574.     case FLONUM:    return (getflonum(val));
  575.     }
  576.     return ((FLOTYPE)0); /* never reached */
  577. }
  578.  
  579. /* checkizero - check for integer division by zero */
  580. static void checkizero(iarg)
  581.   FIXTYPE iarg;
  582. {
  583.     if (iarg == 0)
  584.     xlfail("division by zero");
  585. }
  586.  
  587. /* checkineg - check for square root of a negative number */
  588. static void checkineg(iarg)
  589.   FIXTYPE iarg;
  590. {
  591.     if (iarg < 0)
  592.     xlfail("square root of a negative number");
  593. }
  594.  
  595. /* checkfzero - check for floating point division by zero */
  596. static void checkfzero(farg)
  597.   FLOTYPE farg;
  598. {
  599.     if (farg == 0.0)
  600.     xlfail("division by zero");
  601. }
  602.  
  603. /* checkfneg - check for square root of a negative number */
  604. static void checkfneg(farg)
  605.   FLOTYPE farg;
  606. {
  607.     if (farg < 0.0)
  608.     xlfail("square root of a negative number");
  609. }
  610.  
  611. /* badiop - bad integer operation */
  612. static void badiop()
  613. {
  614.     xlfail("bad integer operation");
  615. }
  616.  
  617. /* badfop - bad floating point operation */
  618. static void badfop()
  619. {
  620.     xlfail("bad floating point operation");
  621. }
  622.