home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / xscheme / xsmath.c < prev    next >
Encoding:
C/C++ Source or Header  |  1989-01-29  |  13.0 KB  |  591 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()    { return (binary('+')); } /* + */
  150. LVAL xsub()    { return (binary('-')); } /* - */
  151. LVAL xmul()    { return (binary('*')); } /* * */
  152. LVAL xdiv()    { return (binary('/')); } /* / */
  153. LVAL xquo()    { return (binary('Q')); } /* quotient */
  154. LVAL xrem()    { return (binary('R')); } /* remainder */
  155. LVAL xmin()    { return (binary('m')); } /* min */
  156. LVAL xmax()    { return (binary('M')); } /* max */
  157. LVAL xexpt()   { return (binary('E')); } /* expt */
  158. LVAL xlogand() { return (binary('&')); } /* logand */
  159. LVAL xlogior() { return (binary('|')); } /* logior */
  160. LVAL xlogxor() { return (binary('^')); } /* logxor */
  161.  
  162. /* binary - handle binary operations */
  163. LOCAL LVAL binary(fcn)
  164.   int fcn;
  165. {
  166.     FIXTYPE ival,iarg;
  167.     FLOTYPE fval,farg;
  168.     LVAL arg;
  169.     int mode;
  170.  
  171.     /* get the first argument */
  172.     arg = xlgetarg();
  173.  
  174.     /* set the type of the first argument */
  175.     if (fixp(arg)) {
  176.     ival = getfixnum(arg);
  177.     mode = 'I';
  178.     }
  179.     else if (floatp(arg)) {
  180.     fval = getflonum(arg);
  181.     mode = 'F';
  182.     }
  183.     else
  184.     xlbadtype(arg);
  185.  
  186.     /* treat a single argument as a special case */
  187.     if (!moreargs()) {
  188.     switch (fcn) {
  189.     case '-':
  190.         switch (mode) {
  191.         case 'I':
  192.         ival = -ival;
  193.         break;
  194.         case 'F':
  195.         fval = -fval;
  196.         break;
  197.         }
  198.         break;
  199.     case '/':
  200.         switch (mode) {
  201.         case 'I':
  202.         checkizero(ival);
  203.         if (ival != 1) {
  204.             fval = 1.0 / (FLOTYPE)ival;
  205.             mode = 'F';
  206.         }
  207.         break;
  208.         case 'F':
  209.         checkfzero(fval);
  210.         fval = 1.0 / fval;
  211.         break;
  212.         }
  213.     }
  214.     }
  215.  
  216.     /* handle each remaining argument */
  217.     while (moreargs()) {
  218.  
  219.     /* get the next argument */
  220.     arg = xlgetarg();
  221.  
  222.     /* check its type */
  223.     if (fixp(arg)) {
  224.         switch (mode) {
  225.         case 'I':
  226.             iarg = getfixnum(arg);
  227.             break;
  228.         case 'F':
  229.             farg = (FLOTYPE)getfixnum(arg);
  230.         break;
  231.         }
  232.     }
  233.     else if (floatp(arg)) {
  234.         switch (mode) {
  235.         case 'I':
  236.             fval = (FLOTYPE)ival;
  237.         farg = getflonum(arg);
  238.         mode = 'F';
  239.         break;
  240.         case 'F':
  241.             farg = getflonum(arg);
  242.         break;
  243.         }
  244.     }
  245.     else
  246.         xlbadtype(arg);
  247.  
  248.     /* accumulate the result value */
  249.     switch (mode) {
  250.     case 'I':
  251.         switch (fcn) {
  252.         case '+':    ival += iarg; break;
  253.         case '-':    ival -= iarg; break;
  254.         case '*':    ival *= iarg; break;
  255.         case '/':    checkizero(iarg);
  256.             if ((ival % iarg) == 0)        
  257.                 ival /= iarg;
  258.             else {
  259.                 fval = (FLOTYPE)ival;
  260.                 farg = (FLOTYPE)iarg;
  261.                 fval /= farg;
  262.                 mode = 'F';
  263.             }
  264.             break;
  265.         case 'Q':    checkizero(iarg); ival /= iarg; break;
  266.         case 'R':    checkizero(iarg); ival %= iarg; break;
  267.         case 'M':    if (iarg > ival) ival = iarg; break;
  268.         case 'm':    if (iarg < ival) ival = iarg; break;
  269.         case 'E':    return (cvflonum((FLOTYPE)pow((FLOTYPE)ival,(FLOTYPE)iarg)));
  270.         case '&':    ival &= iarg; break;
  271.         case '|':    ival |= iarg; break;
  272.         case '^':    ival ^= iarg; break;
  273.         default:    badiop();
  274.         }
  275.         break;
  276.     case 'F':
  277.         switch (fcn) {
  278.         case '+':    fval += farg; break;
  279.         case '-':    fval -= farg; break;
  280.         case '*':    fval *= farg; break;
  281.         case '/':    checkfzero(farg); fval /= farg; break;
  282.         case 'M':    if (farg > fval) fval = farg; break;
  283.         case 'm':    if (farg < fval) fval = farg; break;
  284.         case 'E':    fval = pow(fval,farg); break;
  285.         default:    badfop();
  286.         }
  287.             break;
  288.     }
  289.     }
  290.  
  291.     /* return the result */
  292.     switch (mode) {
  293.     case 'I':    return (cvfixnum(ival));
  294.     case 'F':    return (cvflonum(fval));
  295.     }
  296. }
  297.  
  298. /* unary functions */
  299. LVAL xlognot() { return (unary('~')); } /* lognot */
  300. LVAL xabs()      { return (unary('A')); } /* abs */
  301. LVAL xadd1()     { return (unary('+')); } /* 1+ */
  302. LVAL xsub1()     { return (unary('-')); } /* -1+ */
  303. LVAL xsin()      { return (unary('S')); } /* sin */
  304. LVAL xcos()      { return (unary('C')); } /* cos */
  305. LVAL xtan()      { return (unary('T')); } /* tan */
  306. LVAL xasin()     { return (unary('s')); } /* asin */
  307. LVAL xacos()     { return (unary('c')); } /* acos */
  308. LVAL xexp()      { return (unary('E')); } /* exp */
  309. LVAL xsqrt()     { return (unary('R')); } /* sqrt */
  310. LVAL xlog()      { return (unary('L')); } /* log */
  311. LVAL xrandom()   { return (unary('?')); } /* random */
  312.  
  313. /* unary - handle unary operations */
  314. LOCAL LVAL unary(fcn)
  315.   int fcn;
  316. {
  317.     FLOTYPE fval;
  318.     FIXTYPE ival;
  319.     LVAL arg;
  320.  
  321.     /* get the argument */
  322.     arg = xlgetarg();
  323.     xllastarg();
  324.  
  325.     /* check its type */
  326.     if (fixp(arg)) {
  327.     ival = getfixnum(arg);
  328.     switch (fcn) {
  329.     case '~':    ival = ~ival; break;
  330.     case 'A':    ival = (ival < 0 ? -ival : ival); break;
  331.     case '+':    ival++; break;
  332.     case '-':    ival--; break;
  333.     case 'S':    return (cvflonum((FLOTYPE)sin((FLOTYPE)ival)));
  334.     case 'C':    return (cvflonum((FLOTYPE)cos((FLOTYPE)ival)));
  335.     case 'T':    return (cvflonum((FLOTYPE)tan((FLOTYPE)ival)));
  336.     case 's':    return (cvflonum((FLOTYPE)asin((FLOTYPE)ival)));
  337.     case 'c':    return (cvflonum((FLOTYPE)acos((FLOTYPE)ival)));
  338.     case 't':    return (cvflonum((FLOTYPE)atan((FLOTYPE)ival)));
  339.     case 'E':    return (cvflonum((FLOTYPE)exp((FLOTYPE)ival)));
  340.     case 'L':    return (cvflonum((FLOTYPE)log((FLOTYPE)ival)));
  341.     case 'R':    checkineg(ival);
  342.             return (cvflonum((FLOTYPE)sqrt((FLOTYPE)ival)));
  343.     case '?':    ival = (FIXTYPE)osrand((int)ival); break;
  344.     default:    badiop();
  345.     }
  346.     return (cvfixnum(ival));
  347.     }
  348.     else if (floatp(arg)) {
  349.     fval = getflonum(arg);
  350.     switch (fcn) {
  351.     case 'A':    fval = (fval < 0.0 ? -fval : fval); break;
  352.     case '+':    fval += 1.0; break;
  353.     case '-':    fval -= 1.0; break;
  354.     case 'S':    fval = sin(fval); break;
  355.     case 'C':    fval = cos(fval); break;
  356.     case 'T':    fval = tan(fval); break;
  357.     case 's':    fval = asin(fval); break;
  358.     case 'c':    fval = acos(fval); break;
  359.     case 't':    fval = atan(fval); break;
  360.     case 'E':    fval = exp(fval); break;
  361.     case 'L':    fval = log(fval); break;
  362.     case 'R':    checkfneg(fval);
  363.             fval = sqrt(fval); break;
  364.     default:    badfop();
  365.     }
  366.     return (cvflonum(fval));
  367.     }
  368.     else
  369.     xlbadtype(arg);
  370. }
  371.  
  372. /* xgcd - greatest common divisor */
  373. LVAL xgcd()
  374. {
  375.     FIXTYPE m,n,r;
  376.     LVAL arg;
  377.  
  378.     if (!moreargs())            /* check for identity case */
  379.     return (cvfixnum((FIXTYPE)0));
  380.     arg = xlgafixnum();
  381.     n = getfixnum(arg);
  382.     if (n < (FIXTYPE)0) n = -n;        /* absolute value */
  383.     while (moreargs()) {
  384.     arg = xlgafixnum();
  385.     m = getfixnum(arg);
  386.     if (m < (FIXTYPE)0) m = -m;    /* absolute value */
  387.     for (;;) {            /* euclid's algorithm */
  388.         r = m % n;
  389.         if (r == (FIXTYPE)0)
  390.         break;
  391.         m = n;
  392.         n = r;
  393.     }
  394.     }
  395.     return (cvfixnum(n));
  396. }
  397.  
  398. /* unary predicates */
  399. LVAL xnegativep() { return (predicate('-')); } /* negative? */
  400. LVAL xzerop()     { return (predicate('Z')); } /* zero? */
  401. LVAL xpositivep() { return (predicate('+')); } /* positive? */
  402. LVAL xevenp()     { return (predicate('E')); } /* even? */
  403. LVAL xoddp()      { return (predicate('O')); } /* odd? */
  404.  
  405. /* predicate - handle a predicate function */
  406. LOCAL LVAL predicate(fcn)
  407.   int fcn;
  408. {
  409.     FLOTYPE fval;
  410.     FIXTYPE ival;
  411.     LVAL arg;
  412.  
  413.     /* get the argument */
  414.     arg = xlgetarg();
  415.     xllastarg();
  416.  
  417.     /* check the argument type */
  418.     if (fixp(arg)) {
  419.     ival = getfixnum(arg);
  420.     switch (fcn) {
  421.     case '-':    ival = (ival < 0); break;
  422.     case 'Z':    ival = (ival == 0); break;
  423.     case '+':    ival = (ival > 0); break;
  424.     case 'E':    ival = ((ival & 1) == 0); break;
  425.     case 'O':    ival = ((ival & 1) != 0); break;
  426.     default:    badiop();
  427.     }
  428.     }
  429.     else if (floatp(arg)) {
  430.     fval = getflonum(arg);
  431.     switch (fcn) {
  432.     case '-':    ival = (fval < 0); break;
  433.     case 'Z':    ival = (fval == 0); break;
  434.     case '+':    ival = (fval > 0); break;
  435.     default:    badfop();
  436.     }
  437.     }
  438.     else
  439.     xlbadtype(arg);
  440.  
  441.     /* return the result value */
  442.     return (ival ? true : NIL);
  443. }
  444.  
  445. /* comparison functions */
  446. LVAL xlss() { return (compare('<')); } /* < */
  447. LVAL xleq() { return (compare('L')); } /* <= */
  448. LVAL xeql() { return (compare('=')); } /* = */
  449. LVAL xgeq() { return (compare('G')); } /* >= */
  450. LVAL xgtr() { return (compare('>')); } /* > */
  451.  
  452. /* compare - common compare function */
  453. LOCAL LVAL compare(fcn)
  454.   int fcn;
  455. {
  456.     FIXTYPE icmp,ival,iarg;
  457.     FLOTYPE fcmp,fval,farg;
  458.     LVAL arg;
  459.     int mode;
  460.  
  461.     /* get the first argument */
  462.     arg = xlgetarg();
  463.  
  464.     /* set the type of the first argument */
  465.     if (fixp(arg)) {
  466.     ival = getfixnum(arg);
  467.     mode = 'I';
  468.     }
  469.     else if (floatp(arg)) {
  470.     fval = getflonum(arg);
  471.     mode = 'F';
  472.     }
  473.     else
  474.     xlbadtype(arg);
  475.  
  476.     /* handle each remaining argument */
  477.     for (icmp = TRUE; icmp && moreargs(); ival = iarg, fval = farg) {
  478.  
  479.     /* get the next argument */
  480.     arg = xlgetarg();
  481.  
  482.     /* check its type */
  483.     if (fixp(arg)) {
  484.         switch (mode) {
  485.         case 'I':
  486.             iarg = getfixnum(arg);
  487.             break;
  488.         case 'F':
  489.             farg = (FLOTYPE)getfixnum(arg);
  490.         break;
  491.         }
  492.     }
  493.     else if (floatp(arg)) {
  494.         switch (mode) {
  495.         case 'I':
  496.             fval = (FLOTYPE)ival;
  497.         farg = getflonum(arg);
  498.         mode = 'F';
  499.         break;
  500.         case 'F':
  501.             farg = getflonum(arg);
  502.         break;
  503.         }
  504.     }
  505.     else
  506.         xlbadtype(arg);
  507.  
  508.     /* compute result of the compare */
  509.     switch (mode) {
  510.     case 'I':
  511.         icmp = ival - iarg;
  512.         switch (fcn) {
  513.         case '<':    icmp = (icmp < 0); break;
  514.         case 'L':    icmp = (icmp <= 0); break;
  515.         case '=':    icmp = (icmp == 0); break;
  516.         case 'G':    icmp = (icmp >= 0); break;
  517.         case '>':    icmp = (icmp > 0); break;
  518.         }
  519.         break;
  520.     case 'F':
  521.         fcmp = fval - farg;
  522.         switch (fcn) {
  523.         case '<':    icmp = (fcmp < 0.0); break;
  524.         case 'L':    icmp = (fcmp <= 0.0); break;
  525.         case '=':    icmp = (fcmp == 0.0); break;
  526.         case 'G':    icmp = (fcmp >= 0.0); break;
  527.         case '>':    icmp = (fcmp > 0.0); break;
  528.         }
  529.         break;
  530.     }
  531.     }
  532.  
  533.     /* return the result */
  534.     return (icmp ? true : NIL);
  535. }
  536.  
  537. /* toflotype - convert a lisp value to a floating point number */
  538. FLOTYPE toflotype(val)
  539.   LVAL val;
  540. {
  541.     /* must be a number for this to work */
  542.     switch (ntype(val)) {
  543.     case FIXNUM:    return ((FLOTYPE)getfixnum(val));
  544.     case FLONUM:    return (getflonum(val));
  545.     }
  546. }
  547.  
  548. /* checkizero - check for integer division by zero */
  549. checkizero(iarg)
  550.   FIXTYPE iarg;
  551. {
  552.     if (iarg == 0)
  553.     xlfail("division by zero");
  554. }
  555.  
  556. /* checkineg - check for square root of a negative number */
  557. checkineg(iarg)
  558.   FIXTYPE iarg;
  559. {
  560.     if (iarg < 0)
  561.     xlfail("square root of a negative number");
  562. }
  563.  
  564. /* checkfzero - check for floating point division by zero */
  565. checkfzero(farg)
  566.   FLOTYPE farg;
  567. {
  568.     if (farg == 0.0)
  569.     xlfail("division by zero");
  570. }
  571.  
  572. /* checkfneg - check for square root of a negative number */
  573. checkfneg(farg)
  574.   FLOTYPE farg;
  575. {
  576.     if (farg < 0.0)
  577.     xlfail("square root of a negative number");
  578. }
  579.  
  580. /* badiop - bad integer operation */
  581. LOCAL badiop()
  582. {
  583.     xlfail("bad integer operation");
  584. }
  585.  
  586. /* badfop - bad floating point operation */
  587. LOCAL badfop()
  588. {
  589.     xlfail("bad floating point operation");
  590. }
  591.