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