mirror of
https://github.com/cookiengineer/audacity
synced 2025-05-03 17:19:43 +02:00
452 lines
12 KiB
C
452 lines
12 KiB
C
/* xlmath - xlisp built-in arithmetic functions */
|
|
/* Copyright (c) 1985, by David Michael Betz
|
|
All Rights Reserved
|
|
Permission is granted for unrestricted non-commercial use */
|
|
|
|
/* CHANGE LOG
|
|
* --------------------------------------------------------------------
|
|
* 28Apr03 dm eliminate some compiler warnings
|
|
*/
|
|
|
|
#include "xlisp.h"
|
|
#include <math.h>
|
|
|
|
/* external variables */
|
|
extern LVAL s_true;
|
|
|
|
/* forward declarations */
|
|
FORWARD LOCAL LVAL unary(int fcn);
|
|
FORWARD LOCAL LVAL binary(int fcn);
|
|
FORWARD LOCAL LVAL predicate(int fcn);
|
|
FORWARD LOCAL LVAL compare(int fcn);
|
|
FORWARD LOCAL void badiop(void);
|
|
FORWARD LOCAL void badfop(void);
|
|
|
|
|
|
/* binary functions */
|
|
LVAL xadd(void) { return (binary('+')); } /* + */
|
|
LVAL xsub(void) { return (binary('-')); } /* - */
|
|
LVAL xmul(void) { return (binary('*')); } /* * */
|
|
LVAL xdiv(void) { return (binary('/')); } /* / */
|
|
LVAL xrem(void) { return (binary('%')); } /* rem */
|
|
LVAL xmin(void) { return (binary('m')); } /* min */
|
|
LVAL xmax(void) { return (binary('M')); } /* max */
|
|
LVAL xexpt(void) { return (binary('E')); } /* expt */
|
|
LVAL xlogand(void) { return (binary('&')); } /* logand */
|
|
LVAL xlogior(void) { return (binary('|')); } /* logior */
|
|
LVAL xlogxor(void) { return (binary('^')); } /* logxor */
|
|
LVAL xatan(void) { return (binary('A')); } /* atan */
|
|
|
|
/* xgcd - greatest common divisor */
|
|
LVAL xgcd(void)
|
|
{
|
|
FIXTYPE m,n,r;
|
|
LVAL arg;
|
|
|
|
if (!moreargs()) /* check for identity case */
|
|
return (cvfixnum((FIXTYPE)0));
|
|
arg = xlgafixnum();
|
|
n = getfixnum(arg);
|
|
if (n < (FIXTYPE)0) n = -n; /* absolute value */
|
|
while (moreargs()) {
|
|
arg = xlgafixnum();
|
|
m = getfixnum(arg);
|
|
if (m < (FIXTYPE)0) m = -m; /* absolute value */
|
|
for (;;) { /* euclid's algorithm */
|
|
r = m % n;
|
|
if (r == (FIXTYPE)0)
|
|
break;
|
|
m = n;
|
|
n = r;
|
|
}
|
|
}
|
|
return (cvfixnum(n));
|
|
}
|
|
|
|
/* binary - handle binary operations */
|
|
LOCAL LVAL binary(int fcn)
|
|
{
|
|
FIXTYPE ival=0,iarg=0;
|
|
FLOTYPE fval=0,farg=0;
|
|
LVAL arg;
|
|
int mode=0;
|
|
|
|
/* get the first argument */
|
|
arg = xlgetarg();
|
|
|
|
/* set the type of the first argument */
|
|
if (fixp(arg)) {
|
|
ival = getfixnum(arg);
|
|
mode = 'I';
|
|
}
|
|
else if (floatp(arg)) {
|
|
fval = getflonum(arg);
|
|
mode = 'F';
|
|
}
|
|
else
|
|
xlerror("bad argument type",arg);
|
|
|
|
/* treat a single argument as a special case */
|
|
if (!moreargs()) {
|
|
switch (fcn) {
|
|
case '-':
|
|
switch (mode) {
|
|
case 'I':
|
|
ival = -ival;
|
|
break;
|
|
case 'F':
|
|
fval = -fval;
|
|
break;
|
|
}
|
|
break;
|
|
case '/':
|
|
switch (mode) {
|
|
case 'I':
|
|
checkizero(ival);
|
|
ival = 1 / ival;
|
|
break;
|
|
case 'F':
|
|
checkfzero(fval);
|
|
fval = 1.0 / fval;
|
|
break;
|
|
}
|
|
break;
|
|
case 'A':
|
|
switch (mode) {
|
|
case 'I':
|
|
mode = 'F';
|
|
fval = ival;
|
|
case 'F':
|
|
fval = atan(fval);
|
|
break;
|
|
}
|
|
break;
|
|
}
|
|
}
|
|
|
|
/* handle each remaining argument */
|
|
while (moreargs()) {
|
|
|
|
/* get the next argument */
|
|
arg = xlgetarg();
|
|
|
|
/* check its type */
|
|
if (fixp(arg)) {
|
|
switch (mode) {
|
|
case 'I':
|
|
iarg = getfixnum(arg);
|
|
break;
|
|
case 'F':
|
|
farg = (FLOTYPE)getfixnum(arg);
|
|
break;
|
|
}
|
|
}
|
|
else if (floatp(arg)) {
|
|
switch (mode) {
|
|
case 'I':
|
|
fval = (FLOTYPE)ival;
|
|
farg = getflonum(arg);
|
|
mode = 'F';
|
|
break;
|
|
case 'F':
|
|
farg = getflonum(arg);
|
|
break;
|
|
}
|
|
}
|
|
else
|
|
xlerror("bad argument type",arg);
|
|
|
|
/* accumulate the result value */
|
|
switch (mode) {
|
|
case 'I':
|
|
switch (fcn) {
|
|
case '+': ival += iarg; break;
|
|
case '-': ival -= iarg; break;
|
|
case '*': ival *= iarg; break;
|
|
case '/': checkizero(iarg); ival /= iarg; break;
|
|
case '%': checkizero(iarg); ival %= iarg; break;
|
|
case 'M': if (iarg > ival) ival = iarg; break;
|
|
case 'm': if (iarg < ival) ival = iarg; break;
|
|
case '&': ival &= iarg; break;
|
|
case '|': ival |= iarg; break;
|
|
case '^': ival ^= iarg; break;
|
|
case 'A': fval = atan2((double) ival, (double) iarg);
|
|
mode = 'F';
|
|
xllastarg();
|
|
break;
|
|
default: badiop();
|
|
}
|
|
break;
|
|
case 'F':
|
|
switch (fcn) {
|
|
case '+': fval += farg; break;
|
|
case '-': fval -= farg; break;
|
|
case '*': fval *= farg; break;
|
|
case '/': checkfzero(farg); fval /= farg; break;
|
|
case 'M': if (farg > fval) fval = farg; break;
|
|
case 'm': if (farg < fval) fval = farg; break;
|
|
case 'E': fval = pow(fval,farg); break;
|
|
case 'A': fval = atan2(fval, farg);
|
|
xllastarg();
|
|
break;
|
|
default: badfop();
|
|
}
|
|
break;
|
|
}
|
|
}
|
|
|
|
/* return the result */
|
|
switch (mode) {
|
|
case 'I': return (cvfixnum(ival));
|
|
case 'F': return (cvflonum(fval));
|
|
}
|
|
|
|
/* This shouldn't fall through, but just in case, this will
|
|
catch it and make the compiler happy... */
|
|
xlerror("bad argument type",arg);
|
|
return NULL;
|
|
}
|
|
|
|
/* checkizero - check for integer division by zero */
|
|
void checkizero(FIXTYPE iarg)
|
|
{
|
|
if (iarg == 0)
|
|
xlfail("division by zero");
|
|
}
|
|
|
|
/* checkfzero - check for floating point division by zero */
|
|
void checkfzero(FLOTYPE farg)
|
|
{
|
|
if (farg == 0.0)
|
|
xlfail("division by zero");
|
|
}
|
|
|
|
/* checkfneg - check for square root of a negative number */
|
|
void checkfneg(FLOTYPE farg)
|
|
{
|
|
if (farg < 0.0)
|
|
xlfail("square root of a negative number");
|
|
}
|
|
|
|
/* real-random */
|
|
LVAL xrealrand(void)
|
|
{
|
|
xllastarg();
|
|
return cvflonum(xlrealrand());
|
|
}
|
|
|
|
/* unary functions */
|
|
LVAL xlognot(void) { return (unary('~')); } /* lognot */
|
|
LVAL xabs(void) { return (unary('A')); } /* abs */
|
|
LVAL xadd1(void) { return (unary('+')); } /* 1+ */
|
|
LVAL xsub1(void) { return (unary('-')); } /* 1- */
|
|
LVAL xsin(void) { return (unary('S')); } /* sin */
|
|
LVAL xcos(void) { return (unary('C')); } /* cos */
|
|
LVAL xtan(void) { return (unary('T')); } /* tan */
|
|
LVAL xexp(void) { return (unary('E')); } /* exp */
|
|
LVAL xsqrt(void) { return (unary('R')); } /* sqrt */
|
|
LVAL xfix(void) { return (unary('I')); } /* truncate */
|
|
LVAL xfloat(void) { return (unary('F')); } /* float */
|
|
LVAL xrand(void) { return (unary('?')); } /* random */
|
|
|
|
/* unary - handle unary operations */
|
|
LOCAL LVAL unary(int fcn)
|
|
{
|
|
FLOTYPE fval;
|
|
FIXTYPE ival;
|
|
LVAL arg;
|
|
|
|
/* get the argument */
|
|
arg = xlgetarg();
|
|
xllastarg();
|
|
|
|
/* check its type */
|
|
if (fixp(arg)) {
|
|
ival = getfixnum(arg);
|
|
switch (fcn) {
|
|
case '~': ival = ~ival; break;
|
|
case 'A': ival = (ival < 0 ? -ival : ival); break;
|
|
case '+': ival++; break;
|
|
case '-': ival--; break;
|
|
case 'I': break;
|
|
case 'F': return (cvflonum((FLOTYPE)ival));
|
|
case '?': ival = (FIXTYPE)xlrand((int)ival); break;
|
|
default: badiop();
|
|
}
|
|
return (cvfixnum(ival));
|
|
}
|
|
else if (floatp(arg)) {
|
|
fval = getflonum(arg);
|
|
switch (fcn) {
|
|
case 'A': fval = (fval < 0.0 ? -fval : fval); break;
|
|
case '+': fval += 1.0; break;
|
|
case '-': fval -= 1.0; break;
|
|
case 'S': fval = sin(fval); break;
|
|
case 'C': fval = cos(fval); break;
|
|
case 'T': fval = tan(fval); break;
|
|
case 'E': fval = exp(fval); break;
|
|
case 'R': checkfneg(fval); fval = sqrt(fval); break;
|
|
case 'I': return (cvfixnum((FIXTYPE)fval));
|
|
case 'F': break;
|
|
default: badfop();
|
|
}
|
|
return (cvflonum(fval));
|
|
}
|
|
else {
|
|
xlerror("bad argument type",arg);
|
|
return NULL;
|
|
}
|
|
}
|
|
|
|
/* unary predicates */
|
|
LVAL xminusp(void) { return (predicate('-')); } /* minusp */
|
|
LVAL xzerop(void) { return (predicate('Z')); } /* zerop */
|
|
LVAL xplusp(void) { return (predicate('+')); } /* plusp */
|
|
LVAL xevenp(void) { return (predicate('E')); } /* evenp */
|
|
LVAL xoddp(void) { return (predicate('O')); } /* oddp */
|
|
|
|
/* predicate - handle a predicate function */
|
|
LOCAL LVAL predicate(int fcn)
|
|
{
|
|
FLOTYPE fval;
|
|
FIXTYPE ival=0;
|
|
LVAL arg;
|
|
|
|
/* get the argument */
|
|
arg = xlgetarg();
|
|
xllastarg();
|
|
|
|
/* check the argument type */
|
|
if (fixp(arg)) {
|
|
ival = getfixnum(arg);
|
|
switch (fcn) {
|
|
case '-': ival = (ival < 0); break;
|
|
case 'Z': ival = (ival == 0); break;
|
|
case '+': ival = (ival > 0); break;
|
|
case 'E': ival = ((ival & 1) == 0); break;
|
|
case 'O': ival = ((ival & 1) != 0); break;
|
|
default: badiop();
|
|
}
|
|
}
|
|
else if (floatp(arg)) {
|
|
fval = getflonum(arg);
|
|
switch (fcn) {
|
|
case '-': ival = (fval < 0); break;
|
|
case 'Z': ival = (fval == 0); break;
|
|
case '+': ival = (fval > 0); break;
|
|
default: badfop();
|
|
}
|
|
}
|
|
else
|
|
xlerror("bad argument type",arg);
|
|
|
|
/* return the result value */
|
|
return (ival ? s_true : NIL);
|
|
}
|
|
|
|
/* comparison functions */
|
|
LVAL xlss(void) { return (compare('<')); } /* < */
|
|
LVAL xleq(void) { return (compare('L')); } /* <= */
|
|
LVAL xequ(void) { return (compare('=')); } /* = */
|
|
LVAL xneq(void) { return (compare('#')); } /* /= */
|
|
LVAL xgeq(void) { return (compare('G')); } /* >= */
|
|
LVAL xgtr(void) { return (compare('>')); } /* > */
|
|
|
|
/* compare - common compare function */
|
|
LOCAL LVAL compare(int fcn)
|
|
{
|
|
FIXTYPE icmp,ival=0,iarg=0;
|
|
FLOTYPE fcmp,fval=0,farg=0;
|
|
LVAL arg;
|
|
int mode=0;
|
|
|
|
/* get the first argument */
|
|
arg = xlgetarg();
|
|
|
|
/* set the type of the first argument */
|
|
if (fixp(arg)) {
|
|
ival = getfixnum(arg);
|
|
mode = 'I';
|
|
}
|
|
else if (floatp(arg)) {
|
|
fval = getflonum(arg);
|
|
mode = 'F';
|
|
}
|
|
else
|
|
xlerror("bad argument type",arg);
|
|
|
|
/* handle each remaining argument */
|
|
for (icmp = TRUE; icmp && moreargs(); ival = iarg, fval = farg) {
|
|
|
|
/* get the next argument */
|
|
arg = xlgetarg();
|
|
|
|
/* check its type */
|
|
if (fixp(arg)) {
|
|
switch (mode) {
|
|
case 'I':
|
|
iarg = getfixnum(arg);
|
|
break;
|
|
case 'F':
|
|
farg = (FLOTYPE)getfixnum(arg);
|
|
break;
|
|
}
|
|
}
|
|
else if (floatp(arg)) {
|
|
switch (mode) {
|
|
case 'I':
|
|
fval = (FLOTYPE)ival;
|
|
farg = getflonum(arg);
|
|
mode = 'F';
|
|
break;
|
|
case 'F':
|
|
farg = getflonum(arg);
|
|
break;
|
|
}
|
|
}
|
|
else
|
|
xlerror("bad argument type",arg);
|
|
|
|
/* compute result of the compare */
|
|
switch (mode) {
|
|
case 'I':
|
|
icmp = ival - iarg;
|
|
switch (fcn) {
|
|
case '<': icmp = (icmp < 0); break;
|
|
case 'L': icmp = (icmp <= 0); break;
|
|
case '=': icmp = (icmp == 0); break;
|
|
case '#': icmp = (icmp != 0); break;
|
|
case 'G': icmp = (icmp >= 0); break;
|
|
case '>': icmp = (icmp > 0); break;
|
|
}
|
|
break;
|
|
case 'F':
|
|
fcmp = fval - farg;
|
|
switch (fcn) {
|
|
case '<': icmp = (fcmp < 0.0); break;
|
|
case 'L': icmp = (fcmp <= 0.0); break;
|
|
case '=': icmp = (fcmp == 0.0); break;
|
|
case '#': icmp = (fcmp != 0.0); break;
|
|
case 'G': icmp = (fcmp >= 0.0); break;
|
|
case '>': icmp = (fcmp > 0.0); break;
|
|
}
|
|
break;
|
|
}
|
|
}
|
|
|
|
/* return the result */
|
|
return (icmp ? s_true : NIL);
|
|
}
|
|
|
|
/* badiop - bad integer operation */
|
|
LOCAL void badiop(void)
|
|
{
|
|
xlfail("bad integer operation");
|
|
}
|
|
|
|
/* badfop - bad floating point operation */
|
|
LOCAL void badfop(void)
|
|
{
|
|
xlfail("bad floating point operation");
|
|
}
|