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