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