1 /* arith12.c Copyright (C) 1990-2008 Codemist Ltd */
2
3 /*
4 * Arithmetic functions... specials for Reduce (esp. factoriser)
5 *
6 */
7
8
9 /**************************************************************************
10 * Copyright (C) 2008, Codemist Ltd. A C Norman *
11 * *
12 * Redistribution and use in source and binary forms, with or without *
13 * modification, are permitted provided that the following conditions are *
14 * met: *
15 * *
16 * * Redistributions of source code must retain the relevant *
17 * copyright notice, this list of conditions and the following *
18 * disclaimer. *
19 * * Redistributions in binary form must reproduce the above *
20 * copyright notice, this list of conditions and the following *
21 * disclaimer in the documentation and/or other materials provided *
22 * with the distribution. *
23 * *
24 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *
25 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *
26 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *
27 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *
28 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *
29 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *
30 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS *
31 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
32 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR *
33 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF *
34 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *
35 * DAMAGE. *
36 *************************************************************************/
37
38
39 /* Signature: 5768c7ec 24-May-2008 */
40
41
42 #include "headers.h"
43
44
45 #define FP_EVALUATE 1
46
47
Lfrexp(Lisp_Object nil,Lisp_Object a)48 Lisp_Object Lfrexp(Lisp_Object nil, Lisp_Object a)
49 {
50 double d;
51 int x;
52 d = float_of_number(a);
53 d = frexp(d, &x);
54 if (d == 1.0) d = 0.5, x++;
55 a = make_boxfloat(d, TYPE_DOUBLE_FLOAT);
56 errexit();
57 return Lcons(nil, fixnum_of_int((int32_t)x), a);
58 }
59
Lmodular_difference(Lisp_Object nil,Lisp_Object a,Lisp_Object b)60 Lisp_Object Lmodular_difference(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
61 {
62 int32_t r;
63 CSL_IGNORE(nil);
64 r = int_of_fixnum(a) - int_of_fixnum(b);
65 if (r < 0) r += current_modulus;
66 return onevalue(fixnum_of_int(r));
67 }
68
Lmodular_minus(Lisp_Object nil,Lisp_Object a)69 Lisp_Object Lmodular_minus(Lisp_Object nil, Lisp_Object a)
70 {
71 CSL_IGNORE(nil);
72 if (a != fixnum_of_int(0))
73 { int32_t r = current_modulus - int_of_fixnum(a);
74 a = fixnum_of_int(r);
75 }
76 return onevalue(a);
77 }
78
Lmodular_number(Lisp_Object nil,Lisp_Object a)79 Lisp_Object Lmodular_number(Lisp_Object nil, Lisp_Object a)
80 {
81 int32_t r;
82 a = Cremainder(a, fixnum_of_int(current_modulus));
83 errexit();
84 r = int_of_fixnum(a);
85 if (r < 0) r += current_modulus;
86 return onevalue(fixnum_of_int(r));
87 }
88
Lmodular_plus(Lisp_Object nil,Lisp_Object a,Lisp_Object b)89 Lisp_Object Lmodular_plus(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
90 {
91 int32_t r;
92 CSL_IGNORE(nil);
93 r = int_of_fixnum(a) + int_of_fixnum(b);
94 if (r >= current_modulus) r -= current_modulus;
95 return onevalue(fixnum_of_int(r));
96 }
97
Lmodular_reciprocal(Lisp_Object nil,Lisp_Object n)98 Lisp_Object Lmodular_reciprocal(Lisp_Object nil, Lisp_Object n)
99 {
100 int32_t a, b, x, y;
101 CSL_IGNORE(nil);
102 a = current_modulus;
103 b = int_of_fixnum(n);
104 x = 0;
105 y = 1;
106 if (b == 0) return aerror1("modular-reciprocal", n);
107 if (b < 0) b = current_modulus - ((-b)%current_modulus);
108 while (b != 1)
109 { int32_t w, t;
110 if (b == 0)
111 return aerror1("non-prime modulus in modular-reciprocal",
112 fixnum_of_int(current_modulus));
113 w = a / b;
114 t = b;
115 b = a - b*w;
116 a = t;
117 t = y;
118 y = x - y*w;
119 x = t;
120 }
121 if (y < 0) y += current_modulus;
122 return onevalue(fixnum_of_int(y));
123 }
124
Lmodular_times(Lisp_Object nil,Lisp_Object a,Lisp_Object b)125 Lisp_Object Lmodular_times(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
126 {
127 #ifndef HAVE_UINT64_T
128 uint32_t h, l;
129 #endif
130 uint32_t r, cm;
131 int32_t aa, bb;
132 CSL_IGNORE(nil);
133 cm = (uint32_t)current_modulus;
134 aa = int_of_fixnum(a);
135 bb = int_of_fixnum(b);
136 /*
137 * The constant 46341 is sqrt(2^31) suitable rounded - if my modulus
138 * is no bigger than that then a and b will both be strictly smaller,
139 * and hence a*b will be < 2^31 and hence in range for 32-bit signed
140 * arithmetic. I make this test because I expect Imultiply and Idivide
141 * to be pretty painful, while regular C multiplication and division are
142 * (probably!) much better.
143 */
144 if (cm <= 46341U) r = (aa * bb) % cm;
145 else
146 {
147 #ifdef HAVE_UINT64_T
148 r = (uint32_t)(((uint64_t)aa * (uint64_t)bb) % (uint32_t)cm);
149 #else
150 Dmultiply(h, l, aa, bb, 0);
151 Ddivide(r, l, h, l, cm);
152 #endif
153 }
154 return onevalue(fixnum_of_int(r));
155 }
156
Lmodular_quotient(Lisp_Object nil,Lisp_Object a,Lisp_Object b)157 Lisp_Object Lmodular_quotient(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
158 {
159 CSL_IGNORE(nil);
160 push(a);
161 b = Lmodular_reciprocal(nil, b);
162 pop(a);
163 errexit();
164 return Lmodular_times(nil, a, b);
165 }
166
Lmodular_expt(Lisp_Object nil,Lisp_Object a,Lisp_Object b)167 Lisp_Object Lmodular_expt(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
168 {
169 int32_t x, r, p;
170 uint32_t h, l;
171 CSL_IGNORE(nil);
172 x = int_of_fixnum(b);
173 if (x == 0) return onevalue(fixnum_of_int(1));
174 p = int_of_fixnum(a);
175 /*
176 * I could play games here on half-length current_modulus and use
177 * native C arithmetic, but I judge this case not to be quite that
178 * critically important. Also on 64-bit machines I could do more
179 * work in-line.
180 */
181 p = p % current_modulus; /* In case somebody is being silly! */
182 while ((x & 1) == 0)
183 { Dmultiply(h, l, p, p, 0);
184 Ddivide(p, l, h, l, current_modulus);
185 x = x/2;
186 }
187 r = p;
188 while (x != 1)
189 { Dmultiply(h, l, p, p, 0);
190 Ddivide(p, l, h, l, current_modulus);
191 x = x/2;
192 if ((x & 1) != 0)
193 { Dmultiply(h, l, r, p, 0);
194 Ddivide(r, l, h, l, current_modulus);
195 }
196 }
197 return onevalue(fixnum_of_int(r));
198 }
199
Lset_small_modulus(Lisp_Object nil,Lisp_Object a)200 Lisp_Object Lset_small_modulus(Lisp_Object nil, Lisp_Object a)
201 {
202 int32_t r, old = current_modulus;
203 CSL_IGNORE(nil);
204 if (!is_fixnum(a)) return aerror1("set-small-modulus", a);
205 r = int_of_fixnum(a);
206 /*
207 * I COULD allow a small modulus of up to 2^27, but for compatibility
208 * with Cambridge Lisp I will limit myself to 24 bits.
209 */
210 if (r > 0x00ffffff) return aerror1("set-small-modulus", a);
211 current_modulus = r;
212 return onevalue(fixnum_of_int(old));
213 }
214
Liadd1(Lisp_Object nil,Lisp_Object a)215 Lisp_Object Liadd1(Lisp_Object nil, Lisp_Object a)
216 {
217 CSL_IGNORE(nil);
218 if (!is_fixnum(a)) return aerror1("iadd1", a);
219 return onevalue((Lisp_Object)((int32_t)a + 0x10));
220 }
221
Lidifference(Lisp_Object nil,Lisp_Object a,Lisp_Object b)222 Lisp_Object Lidifference(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
223 {
224 CSL_IGNORE(nil);
225 if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("idifference", a, b);
226 return onevalue((Lisp_Object)((int32_t)a - (int32_t)b + TAG_FIXNUM));
227 }
228
229 /*
230 * xdifference is provided just for the support of the CASE operator. It
231 * subtracts its arguments but returns NIL if either argument is not
232 * an small integer or if the result overflows.
233 */
234
Lxdifference(Lisp_Object nil,Lisp_Object a,Lisp_Object b)235 Lisp_Object Lxdifference(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
236 {
237 int32_t r;
238 if (!is_fixnum(a) || !is_fixnum(b)) return onevalue(nil);
239 r = int_of_fixnum(a) - int_of_fixnum(b);
240 if (r < -0x08000000 || r > 0x07ffffff) return onevalue(nil);
241 return onevalue(fixnum_of_int(r));
242 }
243
Ligreaterp(Lisp_Object nil,Lisp_Object a,Lisp_Object b)244 Lisp_Object Ligreaterp(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
245 {
246 CSL_IGNORE(nil);
247 if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("igreaterp", a, b);
248 return onevalue(Lispify_predicate(a > b));
249 }
250
Lilessp(Lisp_Object nil,Lisp_Object a,Lisp_Object b)251 Lisp_Object Lilessp(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
252 {
253 CSL_IGNORE(nil);
254 if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("ilessp", a, b);
255 return onevalue(Lispify_predicate(a < b));
256 }
257
Ligeq(Lisp_Object nil,Lisp_Object a,Lisp_Object b)258 Lisp_Object Ligeq(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
259 {
260 CSL_IGNORE(nil);
261 if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("igeq", a, b);
262 return onevalue(Lispify_predicate(a >= b));
263 }
264
Lileq(Lisp_Object nil,Lisp_Object a,Lisp_Object b)265 Lisp_Object Lileq(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
266 {
267 CSL_IGNORE(nil);
268 if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("ileq", a, b);
269 return onevalue(Lispify_predicate(a <= b));
270 }
271
Lilogand(Lisp_Object nil,int nargs,...)272 static Lisp_Object MS_CDECL Lilogand(Lisp_Object nil, int nargs, ...)
273 {
274 va_list a;
275 Lisp_Object r;
276 if (nargs == 0) return onevalue(fixnum_of_int(-1));
277 if (nargs > ARG_CUT_OFF) return aerror("too many args for ilogand");
278 CSL_IGNORE(nil);
279 va_start(a, nargs);
280 r = va_arg(a, Lisp_Object);
281 if (!is_fixnum(r)) return aerror1("ilogand", r);
282 while (--nargs != 0)
283 { Lisp_Object w = va_arg(a, Lisp_Object);
284 if (!is_fixnum(w))
285 { va_end(a);
286 return aerror1("ilogand", w);
287 }
288 r = (Lisp_Object)((int32_t)r & (int32_t)w);
289 }
290 va_end(a);
291 return onevalue(r);
292 }
293
Lilogor(Lisp_Object nil,int nargs,...)294 static Lisp_Object MS_CDECL Lilogor(Lisp_Object nil, int nargs, ...)
295 {
296 va_list a;
297 Lisp_Object r;
298 if (nargs == 0) return onevalue(fixnum_of_int(0));
299 if (nargs > ARG_CUT_OFF) return aerror("too many args for ilogor");
300 CSL_IGNORE(nil);
301 va_start(a, nargs);
302 r = va_arg(a, Lisp_Object);
303 if (!is_fixnum(r)) return aerror1("ilogor", r);
304 while (--nargs != 0)
305 { Lisp_Object w = va_arg(a, Lisp_Object);
306 if (!is_fixnum(w))
307 { va_end(a);
308 return aerror1("ilogor", w);
309 }
310 r = (Lisp_Object)((int32_t)r | (int32_t)w);
311 }
312 va_end(a);
313 return onevalue(r);
314 }
315
Lilogxor(Lisp_Object nil,int nargs,...)316 static Lisp_Object MS_CDECL Lilogxor(Lisp_Object nil, int nargs, ...)
317 {
318 va_list a;
319 Lisp_Object r;
320 if (nargs == 0) return onevalue(fixnum_of_int(0));
321 if (nargs > ARG_CUT_OFF) return aerror("too many args for ilogxor");
322 CSL_IGNORE(nil);
323 va_start(a, nargs);
324 r = va_arg(a, Lisp_Object);
325 if (!is_fixnum(r)) return aerror1("ilogxor", r);
326 while (--nargs != 0)
327 { Lisp_Object w = va_arg(a, Lisp_Object);
328 if (!is_fixnum(w))
329 { va_end(a);
330 return aerror1("ilogxor", w);
331 }
332 r = (Lisp_Object)(((int32_t)r ^ (int32_t)w) + TAG_FIXNUM);
333 }
334 va_end(a);
335 return onevalue(r);
336 }
337
Lilogand2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)338 static Lisp_Object Lilogand2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
339 {
340 CSL_IGNORE(nil);
341 if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("ilogand", a, b);
342 return onevalue(a & b);
343 }
344
Lilogor2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)345 static Lisp_Object Lilogor2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
346 {
347 CSL_IGNORE(nil);
348 if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("ilogor", a, b);
349 return onevalue(a | b);
350 }
351
Lilogxor2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)352 static Lisp_Object Lilogxor2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
353 {
354 CSL_IGNORE(nil);
355 if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("ilogxor", a, b);
356 return onevalue((a ^ b) + TAG_FIXNUM);
357 }
358
Limin(Lisp_Object nil,Lisp_Object a,Lisp_Object b)359 Lisp_Object Limin(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
360 {
361 CSL_IGNORE(nil);
362 if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("imin", a, b);
363 return onevalue(a < b ? a : b);
364 }
365
Limax(Lisp_Object nil,Lisp_Object a,Lisp_Object b)366 Lisp_Object Limax(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
367 {
368 CSL_IGNORE(nil);
369 if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("imax", a, b);
370 return onevalue(a > b ? a : b);
371 }
372
Liminus(Lisp_Object nil,Lisp_Object a)373 Lisp_Object Liminus(Lisp_Object nil, Lisp_Object a)
374 {
375 CSL_IGNORE(nil);
376 if (!is_fixnum(a)) return aerror1("iminus", a);
377 return onevalue((Lisp_Object)(2*TAG_FIXNUM - (int32_t)a));
378 }
379
Liminusp(Lisp_Object nil,Lisp_Object a)380 Lisp_Object Liminusp(Lisp_Object nil, Lisp_Object a)
381 {
382 CSL_IGNORE(nil);
383 return onevalue(Lispify_predicate((int32_t)a < (int32_t)fixnum_of_int(0)));
384 }
385
Liplus(Lisp_Object nil,int nargs,...)386 static Lisp_Object MS_CDECL Liplus(Lisp_Object nil, int nargs, ...)
387 {
388 va_list a;
389 Lisp_Object r;
390 if (nargs == 0) return onevalue(fixnum_of_int(0));
391 if (nargs > ARG_CUT_OFF) return aerror("too many args for iplus");
392 CSL_IGNORE(nil);
393 va_start(a, nargs);
394 r = va_arg(a, Lisp_Object);
395 if (!is_fixnum(r)) return aerror1("iplus", r);
396 while (--nargs != 0)
397 { Lisp_Object w = va_arg(a, Lisp_Object);
398 if (!is_fixnum(w))
399 { va_end(a);
400 return aerror1("iplus", w);
401 }
402 r = (Lisp_Object)((int32_t)r + (int32_t)w - TAG_FIXNUM);
403 }
404 va_end(a);
405 return onevalue(r);
406 }
407
Liplus2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)408 Lisp_Object Liplus2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
409 {
410 CSL_IGNORE(nil);
411 if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("iplus2", a, b);
412 return onevalue((Lisp_Object)((int32_t)a + (int32_t)b - TAG_FIXNUM));
413 }
414
Liquotient(Lisp_Object nil,Lisp_Object a,Lisp_Object b)415 Lisp_Object Liquotient(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
416 {
417 int32_t aa, bb, c;
418 CSL_IGNORE(nil);
419 if (!is_fixnum(a) || !is_fixnum(b) ||
420 b == fixnum_of_int(0)) return aerror2("iquotient", a, b);
421 /* C does not define the exact behaviour of /, % on -ve args */
422 aa = int_of_fixnum(a);
423 bb = int_of_fixnum(b);
424 c = aa % bb;
425 if (aa < 0)
426 { if (c > 0) c -= bb;
427 }
428 else if (c < 0) c += bb;
429 return onevalue(fixnum_of_int((aa-c)/bb));
430 }
431
Liremainder(Lisp_Object nil,Lisp_Object a,Lisp_Object b)432 Lisp_Object Liremainder(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
433 {
434 int32_t aa, bb, c;
435 CSL_IGNORE(nil);
436 if (!is_fixnum(a) || !is_fixnum(b) ||
437 b == fixnum_of_int(0)) return aerror2("iremainder", a, b);
438 /* C does not define the exact behaviour of /, % on -ve args */
439 aa = int_of_fixnum(a);
440 bb = int_of_fixnum(b);
441 c = aa % bb;
442 if (aa < 0)
443 { if (c > 0) c -= bb;
444 }
445 else if (c < 0) c += bb;
446 return onevalue(fixnum_of_int(c));
447 }
448
Lirightshift(Lisp_Object nil,Lisp_Object a,Lisp_Object b)449 Lisp_Object Lirightshift(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
450 {
451 CSL_IGNORE(nil);
452 if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("irightshift", a, b);
453 return onevalue(fixnum_of_int(int_of_fixnum(a) >> int_of_fixnum(b)));
454 }
455
Lisub1(Lisp_Object nil,Lisp_Object a)456 Lisp_Object Lisub1(Lisp_Object nil, Lisp_Object a)
457 {
458 CSL_IGNORE(nil);
459 if (!is_fixnum(a)) return aerror1("isub1", a);
460 return onevalue((Lisp_Object)((int32_t)a - 0x10));
461 }
462
Litimes(Lisp_Object nil,int nargs,...)463 static Lisp_Object MS_CDECL Litimes(Lisp_Object nil, int nargs, ...)
464 {
465 va_list a;
466 Lisp_Object rr;
467 int32_t r;
468 if (nargs == 0) return onevalue(fixnum_of_int(1));
469 if (nargs > ARG_CUT_OFF) return aerror("too many args for itimes");
470 CSL_IGNORE(nil);
471 va_start(a, nargs);
472 rr = va_arg(a, Lisp_Object);
473 if (!is_fixnum(rr)) return aerror1("itimes", rr);
474 r = int_of_fixnum(rr);
475 while (nargs-- != 0)
476 { Lisp_Object w = va_arg(a, Lisp_Object);
477 if (!is_fixnum(w))
478 { va_end(a);
479 return aerror1("itimes", w);
480 }
481 r = r * int_of_fixnum(w);
482 }
483 va_end(a);
484 return onevalue(fixnum_of_int(r));
485 }
486
Litimes2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)487 Lisp_Object Litimes2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
488 {
489 CSL_IGNORE(nil);
490 if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("itimes2", a, b);
491 return onevalue(fixnum_of_int(int_of_fixnum(a) * int_of_fixnum(b)));
492 }
493
Lionep(Lisp_Object nil,Lisp_Object a)494 Lisp_Object Lionep(Lisp_Object nil, Lisp_Object a)
495 {
496 CSL_IGNORE(nil);
497 return onevalue(Lispify_predicate((int32_t)a == (int32_t)fixnum_of_int(1)));
498 }
499
Lizerop(Lisp_Object nil,Lisp_Object a)500 Lisp_Object Lizerop(Lisp_Object nil, Lisp_Object a)
501 {
502 CSL_IGNORE(nil);
503 return onevalue(Lispify_predicate((int32_t)a == (int32_t)fixnum_of_int(0)));
504 }
505
506 #ifdef FP_EVALUATE
507
508 static double fp_args[32];
509 static double fp_stack[16];
510
511 /* codes 0 to 31 just load up arguments */
512 #define FP_RETURN 32
513 #define FP_PLUS 33
514 #define FP_DIFFERENCE 34
515 #define FP_TIMES 35
516 #define FP_QUOTIENT 36
517 #define FP_MINUS 37
518 #define FP_SQUARE 38
519 #define FP_CUBE 39
520 #define FP_SIN 40
521 #define FP_COS 41
522 #define FP_TAN 42
523 #define FP_EXP 43
524 #define FP_LOG 44
525 #define FP_SQRT 45
526
527
Lfp_eval(Lisp_Object nil,Lisp_Object code,Lisp_Object args)528 static Lisp_Object Lfp_eval(Lisp_Object nil, Lisp_Object code,
529 Lisp_Object args)
530 /*
531 * The object of this code is to support fast evaluation of numeric
532 * expressions. The first argument is a vector of byte opcodes, while
533 * the second arg is a list of floating point values whose value will (or
534 * at least may) be used. There are at most 32 values in this list.
535 */
536 {
537 int n = 0;
538 double w;
539 unsigned char *p;
540 if (!is_vector(code)) return aerror("fp-evaluate");
541 while (consp(args))
542 { fp_args[n++] = float_of_number(qcar(args));
543 args = qcdr(args);
544 }
545 n = 0;
546 p = &ucelt(code, 0);
547 for (;;)
548 { int op = *p++;
549 /*
550 * Opcodes 0 to 31 just load up the corresponding input value.
551 */
552 if (op < 32)
553 { fp_stack[n++] = fp_args[op];
554 continue;
555 }
556 switch (op)
557 {
558 default:
559 return aerror("Bad op in fp-evaluate");
560 case FP_RETURN:
561 args = make_boxfloat(fp_stack[0], TYPE_DOUBLE_FLOAT);
562 errexit();
563 return onevalue(args);
564 case FP_PLUS:
565 n--;
566 fp_stack[n] += fp_stack[n-1];
567 continue;
568 case FP_DIFFERENCE:
569 n--;
570 fp_stack[n] -= fp_stack[n-1];
571 continue;
572 case FP_TIMES:
573 n--;
574 fp_stack[n] *= fp_stack[n-1];
575 continue;
576 case FP_QUOTIENT:
577 n--;
578 fp_stack[n] /= fp_stack[n-1];
579 continue;
580 case FP_MINUS:
581 fp_stack[n] = -fp_stack[n];
582 continue;
583 case FP_SQUARE:
584 fp_stack[n] *= fp_stack[n];
585 continue;
586 case FP_CUBE:
587 w = fp_stack[n];
588 w *= w;
589 fp_stack[n] *= w;
590 continue;
591 case FP_SIN:
592 fp_stack[n] = sin(fp_stack[n]);
593 continue;
594 case FP_COS:
595 fp_stack[n] = cos(fp_stack[n]);
596 continue;
597 case FP_TAN:
598 fp_stack[n] = tan(fp_stack[n]);
599 continue;
600 case FP_EXP:
601 fp_stack[n] = exp(fp_stack[n]);
602 continue;
603 case FP_LOG:
604 fp_stack[n] = log(fp_stack[n]);
605 continue;
606 case FP_SQRT:
607 fp_stack[n] = sqrt(fp_stack[n]);
608 continue;
609 }
610 }
611 }
612
613 #endif
614
615 setup_type const arith12_setup[] =
616 {
617 {"frexp", Lfrexp, too_many_1, wrong_no_1},
618 {"modular-difference", too_few_2, Lmodular_difference, wrong_no_2},
619 {"modular-minus", Lmodular_minus, too_many_1, wrong_no_1},
620 {"modular-number", Lmodular_number, too_many_1, wrong_no_1},
621 {"modular-plus", too_few_2, Lmodular_plus, wrong_no_2},
622 {"modular-quotient", too_few_2, Lmodular_quotient, wrong_no_2},
623 {"modular-reciprocal", Lmodular_reciprocal, too_many_1, wrong_no_1},
624 {"modular-times", too_few_2, Lmodular_times, wrong_no_2},
625 {"modular-expt", too_few_2, Lmodular_expt, wrong_no_2},
626 {"set-small-modulus", Lset_small_modulus, too_many_1, wrong_no_1},
627 {"iadd1", Liadd1, too_many_1, wrong_no_1},
628 {"idifference", too_few_2, Lidifference, wrong_no_2},
629 {"xdifference", too_few_2, Lxdifference, wrong_no_2},
630 {"igeq", too_few_2, Ligeq, wrong_no_2},
631 {"igreaterp", too_few_2, Ligreaterp, wrong_no_2},
632 {"ileq", too_few_2, Lileq, wrong_no_2},
633 {"ilessp", too_few_2, Lilessp, wrong_no_2},
634 {"ilogand", Lidentity, Lilogand2, Lilogand},
635 {"ilogor", Lidentity, Lilogor2, Lilogor},
636 {"ilogxor", Lidentity, Lilogxor2, Lilogxor},
637 {"imax", too_few_2, Limax, wrong_no_2},
638 {"imin", too_few_2, Limin, wrong_no_2},
639 {"iminus", Liminus, too_many_1, wrong_no_1},
640 {"iminusp", Liminusp, too_many_1, wrong_no_1},
641 {"iplus", Lidentity, Liplus2, Liplus},
642 {"iplus2", too_few_2, Liplus2, wrong_no_2},
643 {"iquotient", too_few_2, Liquotient, wrong_no_2},
644 {"iremainder", too_few_2, Liremainder, wrong_no_2},
645 {"irightshift", too_few_2, Lirightshift, wrong_no_2},
646 {"isub1", Lisub1, too_many_1, wrong_no_1},
647 {"itimes", Lidentity, Litimes2, Litimes},
648 {"itimes2", too_few_2, Litimes2, wrong_no_2},
649 {"ionep", Lionep, too_many_1, wrong_no_1},
650 {"izerop", Lizerop, too_many_1, wrong_no_1},
651 #ifdef FP_EVALUATE
652 {"fp-evaluate", too_few_2, Lfp_eval, wrong_no_2},
653 #endif
654 {NULL, 0, 0, 0}
655 };
656
657 /* end of arith12.c */
658