1 /* arith06.c Copyright (C) 1990-2008 Codemist Ltd */
2
3 /*
4 * Arithmetic functions... lots of Lisp entrypoints.
5 * note that for CSL I want plus and times to be special forms.
6 */
7
8 /**************************************************************************
9 * Copyright (C) 2008, Codemist Ltd. A C Norman *
10 * *
11 * Redistribution and use in source and binary forms, with or without *
12 * modification, are permitted provided that the following conditions are *
13 * met: *
14 * *
15 * * Redistributions of source code must retain the relevant *
16 * copyright notice, this list of conditions and the following *
17 * disclaimer. *
18 * * Redistributions in binary form must reproduce the above *
19 * copyright notice, this list of conditions and the following *
20 * disclaimer in the documentation and/or other materials provided *
21 * with the distribution. *
22 * *
23 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *
24 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *
25 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *
26 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *
27 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *
28 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *
29 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS *
30 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
31 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR *
32 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF *
33 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *
34 * DAMAGE. *
35 *************************************************************************/
36
37
38 /* Signature: 46797271 04-Jul-2009 */
39
40 #include "headers.h"
41
42
43
44 /*****************************************************************************/
45 /*** Lisp-callable versions of arithmetic functions ***/
46 /*****************************************************************************/
47
48
49
Ladd1(Lisp_Object nil,Lisp_Object a)50 Lisp_Object Ladd1(Lisp_Object nil, Lisp_Object a)
51 {
52 if (is_fixnum(a))
53 { /* fixnums have data shifted left 4 bits */
54 if (a == 0x7ffffff1) /* The ONLY possible overflow case here */
55 a = make_one_word_bignum(0x08000000);
56 else return onevalue((Lisp_Object)(a + 0x10)); /* the cheap case */
57 }
58 else a = plus2(a, fixnum_of_int(1));
59 errexit();
60 return onevalue(a);
61 }
62
Lsub1(Lisp_Object nil,Lisp_Object a)63 Lisp_Object Lsub1(Lisp_Object nil, Lisp_Object a)
64 {
65 if (is_fixnum(a))
66 { if (a == ~0x7ffffffe) /* The ONLY possible overflow case here */
67 return make_one_word_bignum(int_of_fixnum(a) - 1);
68 else return onevalue((Lisp_Object)(a - 0x10));
69 }
70 else a = plus2(a, fixnum_of_int(-1));
71 errexit();
72 return onevalue(a);
73 }
74
75 #ifdef COMMON
Lfloat_2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)76 Lisp_Object Lfloat_2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
77 {
78 CSL_IGNORE(nil);
79 if (is_sfloat(b))
80 { double d = float_of_number(a);
81 return onevalue(make_sfloat(d));
82 }
83 else if (!is_bfloat(b)) return aerror1("bad arg for float", b);
84 else
85 { double d = float_of_number(a);
86 return onevalue(make_boxfloat(d, type_of_header(flthdr(b))));
87 }
88 }
89 #endif
90
Lfloat(Lisp_Object nil,Lisp_Object a)91 Lisp_Object Lfloat(Lisp_Object nil, Lisp_Object a)
92 {
93 double d;
94 CSL_IGNORE(nil);
95 if (!is_number(a)) return aerror1("bad arg for float", a);
96 d = float_of_number(a);
97 #ifdef COMMON
98 /* Do we REALLY want single precision by default here? */
99 return onevalue(make_boxfloat(d, TYPE_SINGLE_FLOAT));
100 #else
101 return onevalue(make_boxfloat(d, TYPE_DOUBLE_FLOAT));
102 #endif
103 }
104
Llognot(Lisp_Object nil,Lisp_Object a)105 Lisp_Object Llognot(Lisp_Object nil, Lisp_Object a)
106 {
107 a = lognot(a);
108 errexit();
109 return onevalue(a);
110 }
111
Lash(Lisp_Object nil,Lisp_Object a,Lisp_Object b)112 Lisp_Object Lash(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
113 {
114 a = ash(a, b);
115 errexit();
116 return onevalue(a);
117 }
118
Lash1(Lisp_Object nil,Lisp_Object a,Lisp_Object b)119 Lisp_Object Lash1(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
120 /*
121 * This function multiplies or divides by a power of two. Note that
122 * this corresponds to natural shifts on a sign-and-magnitude machine,
123 * but is not an "arithmetic" shift as that term is understood on
124 * 2's complement machines.
125 */
126 {
127 CSLbool negative = NO;
128 if (!is_fixnum(b)) return aerror("ash1");
129 if (minusp(a))
130 { negative = YES;
131 a = negate(a);
132 }
133 errexit();
134 a = ash(a, b);
135 errexit();
136 if (negative)
137 { a = negate(a);
138 errexit();
139 }
140 return onevalue(a);
141 }
142
143 static int msd_table[256] =
144 {
145 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4,
146 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
147 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
148 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
149 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
150 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
151 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
152 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
153 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
154 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
155 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
156 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
157 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
158 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
159 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
160 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8
161 };
162
Lmsd(Lisp_Object nil,Lisp_Object a)163 Lisp_Object Lmsd(Lisp_Object nil, Lisp_Object a)
164 {
165 int32_t top;
166 int32_t r = 0;
167 CSL_IGNORE(nil);
168 if (is_fixnum(a)) top = int_of_fixnum(a);
169 else if (is_numbers(a))
170 { Header h = numhdr(a);
171 if (!is_bignum_header(h)) return aerror1("bad arg for msd", a);
172 r = (length_of_header(h)-CELL)/4 - 1;
173 top = bignum_digits(a)[r];
174 r = 31*r;
175 }
176 else return aerror1("bad arg for msd", a);
177 if (top < 0) return aerror1("negative arg for msd", a); /* -ve arg */
178 /*
179 * Note that top may be zero here, but in that case the next word down of
180 * the bignum involved MUST be fully normalised with its top bit set.
181 * The effect of this code is that I return (msd 0) => 0.
182 */
183 if (top >= 0x10000) r += 16, top >>= 16;
184 if (top >= 0x100) r += 8, top >>= 8;
185 return onevalue(fixnum_of_int(r + msd_table[top]));
186 }
187
188 static int lsd_table[256] =
189 {
190 8, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
191 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
192 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
193 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
194 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
195 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
196 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
197 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
198 7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
199 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
200 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
201 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
202 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
203 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
204 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
205 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0
206 };
207
Llsd(Lisp_Object nil,Lisp_Object a)208 Lisp_Object Llsd(Lisp_Object nil, Lisp_Object a)
209 {
210 int32_t top;
211 int32_t r = 0;
212 CSL_IGNORE(nil);
213 if (is_fixnum(a))
214 { top = int_of_fixnum(a);
215 /* lsd(0) is taken to have the value 0 here - it is a bit of an odd case */
216 if (top == 0) return onevalue(a);
217 }
218 else if (is_numbers(a))
219 { Header h = numhdr(a);
220 if (!is_bignum_header(h)) return aerror1("bad arg for lsd", a);
221 while ((top = bignum_digits(a)[r]) == 0) r++;
222 r = 31*r;
223 }
224 else return aerror1("bad arg for lsd", a);
225 if (top < 0) return aerror1("negative arg for lsd", a); /* -ve arg */
226 /* top is non-zero here */
227 if ((top & 0xffffu) == 0) r += 16, top >>= 16;
228 if ((top & 0xff) == 0) r += 8, top >>= 8;
229 return onevalue(fixnum_of_int(r + lsd_table[top & 0xff]));
230 }
231
Linorm(Lisp_Object nil,Lisp_Object a,Lisp_Object k)232 Lisp_Object Linorm(Lisp_Object nil, Lisp_Object a, Lisp_Object k)
233 /*
234 * This is a piece of magic especially designed to speed up the
235 * REDUCE big-float code. It adjusts the integer a until it has
236 * just k bits, and returns a correction to the associated exponent.
237 * It combines aspects of msd, lsd, ash and a rounding operation.
238 */
239 {
240 int32_t top, bottom, kk, bits;
241 int32_t rtop = 0, rbottom = 0;
242 CSLbool was_fixnum = NO, was_negative = NO, round_up;
243 if (is_fixnum(k) && (int32_t)k >= 0) kk = int_of_fixnum(k);
244 else return aerror1("bad args for inorm", k);
245 if (is_fixnum(a))
246 { top = int_of_fixnum(a);
247 if (top == 0) return aerror1("zero arg for inorm", a);
248 bottom = top;
249 was_fixnum = YES;
250 }
251 else if (is_numbers(a))
252 { Header h = numhdr(a);
253 if (!is_bignum_header(h)) return aerror1("bad arg for inorm", a);
254 rtop = (length_of_header(h)-CELL)/4 - 1;
255 top = bignum_digits(a)[rtop];
256 was_negative = (top < 0);
257 rtop = 31*rtop;
258 while ((bottom = bignum_digits(a)[rbottom]) == 0) rbottom++;
259 rbottom = 31*rbottom;
260 }
261 else return aerror1("bad arg for inorm", a);
262 if (top < 0) top = ~top; /* Now top is guaranteed positive */
263 if (top >= 0x10000) rtop += 16, top >>= 16;
264 if (top >= 0x100) rtop += 8, top >>= 8;
265 rtop = rtop + msd_table[top];
266 if ((bottom & 0xffffu) == 0) rbottom += 16, bottom >>= 16;
267 if ((bottom & 0xff) == 0) rbottom += 8, bottom >>= 8;
268 rbottom = rbottom + lsd_table[bottom & 0xff];
269 /*
270 * The next line adjusts for the odd case where the input number is
271 * minus an exact power of 2, in which case finding its most significant bit
272 * involved just a little correction.
273 */
274 round_up = was_negative;
275 if (rtop == rbottom) rtop++;
276 bits = rtop - rbottom; /* bits used in the number */
277 if (bits <= kk) kk = rbottom; /* no rounding wanted */
278 else if (was_fixnum)
279 { int bit;
280 /*
281 * If the input was a fixnum and I need to decrease its precision
282 * I will do it in-line here, mainly so that the bignum code that comes
283 * later will not have to worry so much about the possibility of having
284 * any fixnums around.
285 */
286 kk = rtop - kk;
287 bit = ((int32_t)1) << (kk - 1);
288 top = int_of_fixnum(a);
289 if (top < 0)
290 { top = -top;
291 /*
292 * It is almost the case that for negative values I should round if the
293 * bit I want to test is a zero (rather than a 1), but this is not true when
294 * the bit involved is the least significant set bit in the word. So to
295 * keep it simple I negate, test, adjust and negate back when working with
296 * single precision numbers. I also do the shifting right on the positive
297 * value to avoid problems with the bits that get shifted off, and with
298 * computers where right shifts are logical rather than arithmetic.
299 */
300 if ((top & bit) != 0) top += bit;
301 top = top >> kk;
302 top = -top;
303 }
304 else
305 { if ((top & bit) != 0) top += bit;
306 top = top >> kk;
307 }
308 /*
309 * All the shifts I do here move only zero bits off the bottom of the
310 * word, and so there are no issues about +ve vs -ve numbers to bother me.
311 */
312 while ((top & 0xf) == 0)
313 { top = top >> 4;
314 #ifdef SIGNED_SHIFTS_ARE_LOGICAL
315 if (top & 0x08000000) top |= ~0x0fffffff;
316 #endif
317 kk += 4;
318 }
319 while ((top & 0x1) == 0)
320 { top = top >> 1;
321 #ifdef SIGNED_SHIFTS_ARE_LOGICAL
322 if (top & 0x40000000) top |= ~0x7fffffff;
323 #endif
324 kk += 1;
325 }
326 a = cons(fixnum_of_int(top), fixnum_of_int(kk));
327 errexit();
328 return onevalue(a);
329 }
330 else
331 { int32_t wk, bk;
332 /*
333 * Here my input was a bignum and I have established that I not only need
334 * to shift it right but that I will need to lose some non-zero digits from
335 * the right hand end. To cope with this I need to decide whether it will
336 * round up or down, and then perform the appropriate shifts, including a
337 * post-normalisation to ensure that the mantissa of the number as returned
338 * is odd.
339 */
340 kk = rtop - kk;
341 if (rbottom == kk-1) round_up = YES;
342 else
343 { int32_t wk1 = (kk-1) / 31, bk1 = (kk-1) % 31;
344 int32_t bit = ((int32_t)1) << bk1;
345 round_up = ((bit & bignum_digits(a)[wk1]) != 0);
346 if (was_negative) round_up = !round_up;
347 }
348 /*
349 * Now I need to find out how much I will need to shift AFTER rounding
350 * and truncation to leave me with a properly normalised value.
351 */
352 wk = kk / 31, bk = kk % 31;
353 /*
354 * If I have a positive value that is not being rounded up I want to skip
355 * over 0 bits until I find a 1. Similarly for a negative value that is
356 * being rounded up.
357 */
358 if (was_negative == round_up)
359 {
360 for (;;)
361 { int32_t bit = ((int32_t)1) << bk;
362 if ((bignum_digits(a)[wk] & bit) != 0) break;
363 kk++;
364 bk++;
365 if (bk == 31) bk = 0, wk++;
366 }
367 }
368 else
369 /*
370 * A positive value that is being rounded up or a negative one that is not
371 * should cause me to skip over 1 bits until I find a 0. The 0 I find
372 * will be promoted into a 1 achieve the rounding I need.
373 */
374 {
375 for (;;)
376 { int32_t bit = ((int32_t)1) << bk;
377 if ((bignum_digits(a)[wk] & bit) == 0) break;
378 kk++;
379 bk++;
380 if (bk == 31) bk = 0, wk++;
381 }
382 }
383 }
384 if (kk != 0)
385 { a = ash(a, fixnum_of_int(-kk));
386 errexit();
387 /*
388 * All the adjustment I now need to allow for right-shifting negative
389 * numbers and rounding off - at all reduces to just forcing the bottom bit
390 * of the result I compute here to be a 1!
391 */
392 if (is_fixnum(a)) a |= 0x10;
393 else bignum_digits(a)[0] |= 1;
394 }
395 a = cons(a, fixnum_of_int(kk));
396 errexit();
397 return onevalue(a);
398 }
399
400 #ifdef COMMON
401 /*
402 * Implemented as a special form for Standard Lisp. Must be a regular
403 * function in Common Lisp.
404 */
405
Lplus(Lisp_Object nil,int nargs,...)406 static Lisp_Object MS_CDECL Lplus(Lisp_Object nil, int nargs, ...)
407 /*
408 * This adds up a whole bunch of numbers together.
409 * (+ a1 a2 a3 a4 a5) is computed as
410 * (+ a1 (+ a2 (* a3 (+ a4 a5))))
411 */
412 {
413 va_list a;
414 int i;
415 Lisp_Object r;
416 if (nargs == 0) return fixnum_of_int(0);
417 va_start(a, nargs);
418 push_args(a, nargs);
419 /*
420 * The actual args have been passed a C args - I can not afford to
421 * risk garbage collection until they have all been moved somewhere safe,
422 * and here that safe place is the Lisp stack. I have to delay checking for
423 * overflow on same until all args have been pushed.
424 */
425 stackcheck0(nargs);
426 pop(r);
427 nil = C_nil;
428 for (i = 1; i<nargs; i++)
429 { Lisp_Object w;
430 pop(w);
431 if (is_fixnum(r) && is_fixnum(w))
432 { int32_t c = int_of_fixnum(r) + int_of_fixnum(w);
433 int32_t w1 = c & fix_mask;
434 if (w1 == 0 || w1 == fix_mask)
435 { r = fixnum_of_int(c);
436 continue;
437 }
438 }
439 r = plus2(r, w);
440 errexitn(nargs-i);
441 }
442 return onevalue(r);
443 }
444
Ldifference(Lisp_Object nil,int nargs,...)445 static Lisp_Object MS_CDECL Ldifference(Lisp_Object nil, int nargs, ...)
446 {
447 va_list a;
448 Lisp_Object r;
449 int i;
450 if (nargs == 0) return onevalue(fixnum_of_int(0));
451 va_start(a, nargs);
452 push_args(a, nargs);
453 stackcheck0(nargs);
454 nil = C_nil;
455 if (nargs == 1)
456 { pop(r);
457 r = negate(r);
458 errexit();
459 return onevalue(r);
460 }
461 r = stack[1-nargs];
462 /*
463 * (- a1 a2 a3 a4) is computed as
464 * (((a1 - a4) - a3) - a2) which does not seem too bad here.
465 */
466 for (i=1; i<nargs; i++)
467 { Lisp_Object w;
468 pop(w);
469 r = difference2(r, w);
470 errexitn(nargs-i);
471 }
472 popv(1);
473 return onevalue(r);
474 }
475
Ltimes(Lisp_Object nil,int nargs,...)476 static Lisp_Object MS_CDECL Ltimes(Lisp_Object nil, int nargs, ...)
477 /*
478 * This multiplies a whole bunch of numbers together.
479 */
480 {
481 va_list a;
482 int i;
483 Lisp_Object r;
484 if (nargs == 0) return fixnum_of_int(1);
485 va_start(a, nargs);
486 push_args(a, nargs);
487 stackcheck0(nargs);
488 pop(r);
489 nil = C_nil;
490 for (i=1; i<nargs; i++)
491 { Lisp_Object w;
492 pop(w);
493 r = times2(r, w);
494 errexitn(nargs-i);
495 }
496 return onevalue(r);
497 }
498
Lquotient_n(Lisp_Object nil,int nargs,...)499 Lisp_Object MS_CDECL Lquotient_n(Lisp_Object nil, int nargs, ...)
500 {
501 va_list a;
502 Lisp_Object r;
503 int i;
504 if (nargs == 0) return onevalue(fixnum_of_int(1));
505 va_start(a, nargs);
506 push_args(a, nargs);
507 stackcheck0(nargs);
508 if (nargs == 1)
509 { pop(r);
510 r = CLquot2(fixnum_of_int(1), r);
511 errexit();
512 return onevalue(r);
513 }
514 r = stack[1-nargs];
515 for (i=1; i<nargs; i++)
516 { Lisp_Object w;
517 pop(w);
518 r = CLquot2(r, w);
519 errexitn(nargs-i);
520 }
521 popv(1);
522 return onevalue(r);
523 }
524
Lquotient(Lisp_Object nil,Lisp_Object a,Lisp_Object b)525 Lisp_Object Lquotient(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
526 {
527 a = CLquot2(a, b);
528 errexit();
529 return onevalue(a);
530 }
531
LSLquotient(Lisp_Object nil,Lisp_Object a,Lisp_Object b)532 static Lisp_Object LSLquotient(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
533 {
534 a = quot2(a, b);
535 errexit();
536 return onevalue(a);
537 }
538
Lquotient_1(Lisp_Object nil,Lisp_Object b)539 Lisp_Object Lquotient_1(Lisp_Object nil, Lisp_Object b)
540 {
541 b = CLquot2(fixnum_of_int(1), b);
542 errexit();
543 return onevalue(b);
544 }
545
546 #else /* COMMON */
547
Lquotient(Lisp_Object nil,Lisp_Object a,Lisp_Object b)548 Lisp_Object Lquotient(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
549 {
550 a = quot2(a, b);
551 errexit();
552 return onevalue(a);
553 }
554
555 #endif /* COMMON */
556
Ldivide(Lisp_Object nil,Lisp_Object a,Lisp_Object b)557 Lisp_Object Ldivide(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
558 {
559 Lisp_Object q, r;
560 stackcheck2(0, a, b);
561 push2(a, b);
562 q = quot2(a, b);
563 pop2(b, a);
564 errexit();
565 push(q);
566 r = Cremainder(a, b);
567 pop(q);
568 errexit();
569 q = cons(q, r);
570 errexit();
571 return onevalue(q);
572 }
573
Lrem(Lisp_Object nil,Lisp_Object p,Lisp_Object q)574 Lisp_Object Lrem(Lisp_Object nil, Lisp_Object p, Lisp_Object q)
575 {
576 p = Cremainder(p, q);
577 errexit();
578 return onevalue(p);
579 }
580
Lmod(Lisp_Object nil,Lisp_Object p,Lisp_Object q)581 Lisp_Object Lmod(Lisp_Object nil, Lisp_Object p, Lisp_Object q)
582 {
583 p = modulus(p, q);
584 errexit();
585 return onevalue(p);
586 }
587
Lplus2(Lisp_Object nil,Lisp_Object p,Lisp_Object q)588 Lisp_Object Lplus2(Lisp_Object nil, Lisp_Object p, Lisp_Object q)
589 {
590 if (is_fixnum(p) && is_fixnum(q))
591 { int32_t c = int_of_fixnum(p) + int_of_fixnum(q);
592 int32_t w = c & fix_mask;
593 if (w == 0 || w == fix_mask) return onevalue(fixnum_of_int(c));
594 }
595 p = plus2(p, q);
596 errexit();
597 return onevalue(p);
598 }
599
Ltimes2(Lisp_Object nil,Lisp_Object p,Lisp_Object q)600 Lisp_Object Ltimes2(Lisp_Object nil, Lisp_Object p,
601 Lisp_Object q)
602 {
603 p = times2(p, q);
604 errexit();
605 return onevalue(p);
606 }
607
Ldifference2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)608 Lisp_Object Ldifference2(Lisp_Object nil, Lisp_Object a,
609 Lisp_Object b)
610 {
611 a = difference2(a, b);
612 errexit();
613 return onevalue(a);
614 }
615
Lminus(Lisp_Object nil,Lisp_Object a)616 Lisp_Object Lminus(Lisp_Object nil, Lisp_Object a)
617 {
618 a = negate(a);
619 errexit();
620 return onevalue(a);
621 }
622
623 typedef Lisp_Object boolopfn(Lisp_Object, Lisp_Object);
624
625 static struct bfz { boolopfn *fn; Lisp_Object base; } boolop_array[] =
626 {
627 {0, 0},
628 {logand2, fixnum_of_int(-1)},
629 {0, 0},
630 {0, 0},
631 {0, 0},
632 {0, 0},
633 {logxor2, fixnum_of_int(0)},
634 {logior2, fixnum_of_int(0)},
635 {0, 0},
636 {logeqv2, fixnum_of_int(-1)},
637 {0, 0},
638 {0, 0},
639 {0, 0},
640 {0, 0},
641 {0, 0},
642 {0, 0}
643 };
644
645
Lboolfn(Lisp_Object env,int nargs,...)646 static Lisp_Object MS_CDECL Lboolfn(Lisp_Object env, int nargs, ...)
647 {
648 va_list a;
649 Lisp_Object nil = C_nil, r;
650 int i;
651 int32_t what = int_of_fixnum(env);
652 if (nargs == 0) return onevalue(boolop_array[what].base);
653 va_start(a, nargs);
654 push_args(a, nargs);
655 stackcheck0(nargs);
656 pop(r);
657 for (i=1; i<nargs; i++)
658 { Lisp_Object w;
659 pop(w);
660 r = (*boolop_array[what].fn)(r, w);
661 errexitn(nargs-i);
662 }
663 return onevalue(r);
664 }
665
Lzerop(Lisp_Object nil,Lisp_Object a)666 Lisp_Object Lzerop(Lisp_Object nil, Lisp_Object a)
667 {
668 CSLbool fg;
669 fg = zerop(a);
670 errexit();
671 return onevalue(Lispify_predicate(fg));
672 }
673
Lonep(Lisp_Object nil,Lisp_Object a)674 Lisp_Object Lonep(Lisp_Object nil, Lisp_Object a)
675 {
676 CSLbool fg;
677 fg = onep(a);
678 errexit();
679 return onevalue(Lispify_predicate(fg));
680 }
681
Levenp(Lisp_Object nil,Lisp_Object a)682 Lisp_Object Levenp(Lisp_Object nil, Lisp_Object a)
683 {
684 switch ((int)a & TAG_BITS)
685 {
686 case TAG_FIXNUM:
687 return onevalue(((int32_t)a & 0x10) == 0 ? lisp_true : nil);
688 case TAG_NUMBERS:
689 if (is_bignum(a))
690 return onevalue((bignum_digits(a)[0] & 1) == 0 ? lisp_true : nil);
691 /* else drop through */
692 default:
693 return aerror1("bad arg for evenp", a);
694 }
695 }
696
Loddp(Lisp_Object nil,Lisp_Object a)697 Lisp_Object Loddp(Lisp_Object nil, Lisp_Object a)
698 {
699 switch ((int)a & TAG_BITS)
700 {
701 case TAG_FIXNUM:
702 return onevalue(((int32_t)a & 0x10) != 0 ? lisp_true : nil);
703 case TAG_NUMBERS:
704 if (is_bignum(a))
705 return onevalue((bignum_digits(a)[0] & 1) != 0 ? lisp_true : nil);
706 /* else drop through */
707 default:
708 return aerror1("oddp", a);
709 }
710 }
711
Lminusp(Lisp_Object nil,Lisp_Object a)712 Lisp_Object Lminusp(Lisp_Object nil, Lisp_Object a)
713 {
714 /*
715 * For CSL I demand (minusp <non-number>) = nil. Note that this ensures
716 * that minusp will not fail... so nil wil be intact on the way out.
717 */
718 return onevalue(is_number(a) && minusp(a) ? lisp_true : nil);
719 }
720
Lplusp(Lisp_Object nil,Lisp_Object a)721 Lisp_Object Lplusp(Lisp_Object nil, Lisp_Object a)
722 {
723 return onevalue(is_number(a) && plusp(a) ? lisp_true : nil);
724 }
725
726 /*
727 * The next few functions take an arbitrary number of args in Common
728 * Lisp mode but just 2 args in CSL.
729 */
730
731 #ifdef COMMON
732
Leqn_n(Lisp_Object nil,int nargs,...)733 Lisp_Object MS_CDECL Leqn_n(Lisp_Object nil, int nargs, ...)
734 {
735 va_list a;
736 int i;
737 Lisp_Object r;
738 if (nargs < 2) return onevalue(lisp_true);
739 if (nargs > ARG_CUT_OFF) return aerror("too many args for =");
740 va_start(a, nargs);
741 push_args(a, nargs);
742 stackcheck0(nargs);
743 r = stack[1-nargs];
744 for (i = 1; i<nargs; i++)
745 { Lisp_Object s = stack[1+i-nargs];
746 CSLbool w = numeq2(r, s);
747 nil = C_nil;
748 if (exception_pending()) { popv(nargs); return nil; }
749 if (!w)
750 { popv(nargs);
751 return onevalue(nil);
752 }
753 r = s;
754 }
755 popv(nargs);
756 return onevalue(lisp_true);
757 }
758
Leqn(Lisp_Object nil,Lisp_Object a,Lisp_Object b)759 Lisp_Object Leqn(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
760 {
761 CSLbool w = numeq2(a, b);
762 errexit();
763 return onevalue(w ? lisp_true : nil);
764 }
765
Leqn_1(Lisp_Object nil,Lisp_Object a)766 Lisp_Object Leqn_1(Lisp_Object nil, Lisp_Object a)
767 {
768 CSL_IGNORE(nil);
769 CSL_IGNORE(a);
770 return onevalue(lisp_true);
771 }
772
Llessp_n(Lisp_Object nil,int nargs,...)773 Lisp_Object MS_CDECL Llessp_n(Lisp_Object nil, int nargs, ...)
774 {
775 va_list a;
776 int i;
777 Lisp_Object r;
778 if (nargs < 2) return onevalue(lisp_true);
779 if (nargs > ARG_CUT_OFF) return aerror("too many args for <");
780 va_start(a, nargs);
781 push_args(a, nargs);
782 stackcheck0(nargs);
783 r = stack[1-nargs];
784 for (i = 1; i<nargs; i++)
785 { Lisp_Object s = stack[1+i-nargs];
786 CSLbool w = lessp2(r, s);
787 nil = C_nil;
788 if (exception_pending()) { popv(nargs); return nil; }
789 if (!w)
790 { popv(nargs);
791 return onevalue(nil);
792 }
793 r = s;
794 }
795 popv(nargs);
796 return onevalue(lisp_true);
797 }
798
Llessp(Lisp_Object nil,Lisp_Object a,Lisp_Object b)799 Lisp_Object Llessp(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
800 {
801 CSLbool w = lessp2(a, b);
802 errexit();
803 return onevalue(w ? lisp_true : nil);
804 }
805
Llessp_1(Lisp_Object nil,Lisp_Object a)806 Lisp_Object Llessp_1(Lisp_Object nil, Lisp_Object a)
807 {
808 CSL_IGNORE(nil);
809 CSL_IGNORE(a);
810 return onevalue(lisp_true);
811 }
812
Lgreaterp_n(Lisp_Object nil,int nargs,...)813 Lisp_Object MS_CDECL Lgreaterp_n(Lisp_Object nil, int nargs, ...)
814 {
815 va_list a;
816 int i;
817 Lisp_Object r;
818 if (nargs < 2) return onevalue(lisp_true);
819 if (nargs > ARG_CUT_OFF) return aerror("too many args for >");
820 va_start(a, nargs);
821 push_args(a, nargs);
822 stackcheck0(nargs);
823 r = stack[1-nargs];
824 for (i = 1; i<nargs; i++)
825 { Lisp_Object s = stack[1+i-nargs];
826 CSLbool w = lessp2(s, r);
827 nil = C_nil;
828 if (exception_pending()) { popv(nargs); return nil; }
829 if (!w)
830 { popv(nargs);
831 return onevalue(nil);
832 }
833 r = s;
834 }
835 popv(nargs);
836 return onevalue(lisp_true);
837 }
838
Lgreaterp(Lisp_Object nil,Lisp_Object a,Lisp_Object b)839 Lisp_Object Lgreaterp(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
840 {
841 CSLbool w = lessp2(b, a);
842 errexit();
843 return onevalue(w ? lisp_true : nil);
844 }
845
Lgreaterp_1(Lisp_Object nil,Lisp_Object a)846 Lisp_Object Lgreaterp_1(Lisp_Object nil, Lisp_Object a)
847 {
848 CSL_IGNORE(nil);
849 CSL_IGNORE(a);
850 return onevalue(lisp_true);
851 }
852
Lneqn(Lisp_Object nil,int nargs,...)853 static Lisp_Object MS_CDECL Lneqn(Lisp_Object nil, int nargs, ...)
854 /*
855 * /= is supposed to check that NO pair of args match.
856 */
857 {
858 int i, j;
859 Lisp_Object *r;
860 va_list a;
861 if (nargs < 2) return onevalue(lisp_true);
862 r = (Lisp_Object *)&work_1;
863 if (nargs > ARG_CUT_OFF) return aerror("too many args for /=");
864 va_start(a, nargs);
865 for (i=0; i<nargs; i++) r[i] = va_arg(a, Lisp_Object);
866 va_end(a);
867 /*
868 * This bit is OK provided numeq2 does not mess with work_1, ...
869 * and I think that unless funny tracing or errors occur that should
870 * be OK.
871 */
872 for (i = 1; i<nargs; i++)
873 { Lisp_Object n1 = r[i];
874 for (j=0; j<i; j++)
875 { Lisp_Object n2 = r[j];
876 CSLbool w = numeq2(n1, n2);
877 nil = C_nil;
878 if (exception_pending()) return nil;
879 if (w) return onevalue(nil);
880 }
881 }
882 return onevalue(lisp_true);
883 }
884
Lneq_2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)885 Lisp_Object Lneq_2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
886 {
887 CSLbool w = numeq2(a, b);
888 errexit();
889 return onevalue(w ? nil : lisp_true);
890 }
891
Lneq_1(Lisp_Object nil,Lisp_Object a)892 Lisp_Object Lneq_1(Lisp_Object nil, Lisp_Object a)
893 {
894 CSL_IGNORE(nil);
895 CSL_IGNORE(a);
896 return onevalue(lisp_true);
897 }
898
Lgeq_n(Lisp_Object nil,int nargs,...)899 Lisp_Object MS_CDECL Lgeq_n(Lisp_Object nil, int nargs, ...)
900 {
901 va_list a;
902 int i;
903 Lisp_Object r;
904 if (nargs < 2) return onevalue(lisp_true);
905 if (nargs > ARG_CUT_OFF) return aerror("too many args for >=");
906 va_start(a, nargs);
907 push_args(a, nargs);
908 stackcheck0(nargs);
909 r = stack[1-nargs];
910 for (i = 1; i<nargs; i++)
911 { Lisp_Object s = stack[1+i-nargs];
912 CSLbool w = lesseq2(s, r);
913 nil = C_nil;
914 if (exception_pending()) { popv(nargs); return nil; }
915 if (!w)
916 { popv(nargs);
917 return onevalue(nil);
918 }
919 r = s;
920 }
921 popv(nargs);
922 return onevalue(lisp_true);
923 }
924
Lgeq(Lisp_Object nil,Lisp_Object a,Lisp_Object b)925 Lisp_Object Lgeq(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
926 {
927 CSLbool w = lesseq2(b, a);
928 errexit();
929 return onevalue(w ? lisp_true : nil);
930 }
931
Lgeq_1(Lisp_Object nil,Lisp_Object a)932 Lisp_Object Lgeq_1(Lisp_Object nil, Lisp_Object a)
933 {
934 CSL_IGNORE(nil);
935 CSL_IGNORE(a);
936 return onevalue(lisp_true);
937 }
938
Lleq_n(Lisp_Object nil,int nargs,...)939 Lisp_Object MS_CDECL Lleq_n(Lisp_Object nil, int nargs, ...)
940 {
941 va_list a;
942 int i;
943 Lisp_Object r;
944 if (nargs < 2) return onevalue(lisp_true);
945 if (nargs > ARG_CUT_OFF) return aerror("too many args for <=");
946 va_start(a, nargs);
947 push_args(a, nargs);
948 stackcheck0(nargs);
949 r = stack[1-nargs];
950 for (i = 1; i<nargs; i++)
951 { Lisp_Object s = stack[1+i-nargs];
952 CSLbool fg = lesseq2(r, s);
953 nil = C_nil;
954 if (exception_pending()) { popv(nargs); return nil; }
955 if (!fg)
956 { popv(nargs);
957 return onevalue(nil);
958 }
959 r = s;
960 }
961 popv(nargs);
962 return onevalue(lisp_true);
963 }
964
Lleq(Lisp_Object nil,Lisp_Object a,Lisp_Object b)965 Lisp_Object Lleq(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
966 {
967 CSLbool w = lesseq2(a, b);
968 errexit();
969 return onevalue(w ? lisp_true : nil);
970 }
971
Lleq_1(Lisp_Object nil,Lisp_Object a)972 Lisp_Object Lleq_1(Lisp_Object nil, Lisp_Object a)
973 {
974 CSL_IGNORE(nil);
975 CSL_IGNORE(a);
976 return onevalue(lisp_true);
977 }
978
979 #else /* COMMON */
980
981
Leqn(Lisp_Object nil,Lisp_Object a,Lisp_Object b)982 Lisp_Object Leqn(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
983 {
984 CSLbool r;
985 r = numeq2(a, b);
986 errexit();
987 return onevalue(Lispify_predicate(r));
988 }
989
Llessp(Lisp_Object nil,Lisp_Object a,Lisp_Object b)990 Lisp_Object Llessp(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
991 {
992 CSLbool r;
993 /*
994 * I have strongish expectations that fixnum arithmetic is so imporant that
995 * it is worth lifting the fixnum comparison up here.
996 */
997 if (is_fixnum(a) && is_fixnum(b))
998 return onevalue(Lispify_predicate((int32_t)a<(int32_t)b));
999 r = lessp2(a, b);
1000 errexit();
1001 return onevalue(Lispify_predicate(r));
1002 }
1003
Lgreaterp(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1004 Lisp_Object Lgreaterp(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
1005 {
1006 CSLbool r;
1007 if (is_fixnum(a) && is_fixnum(b))
1008 return onevalue(Lispify_predicate((int32_t)a>(int32_t)b));
1009 r = lessp2(b, a);
1010 errexit();
1011 return onevalue(Lispify_predicate(r));
1012 }
1013
Lgeq(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1014 Lisp_Object Lgeq(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
1015 {
1016 CSLbool r;
1017 if (is_fixnum(a) && is_fixnum(b))
1018 return onevalue(Lispify_predicate((int32_t)a>=(int32_t)b));
1019 r = lessp2(a, b);
1020 errexit();
1021 return onevalue(Lispify_predicate(!r));
1022 }
1023
Lleq(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1024 Lisp_Object Lleq(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
1025 {
1026 CSLbool r;
1027 if (is_fixnum(a) && is_fixnum(b))
1028 return onevalue(Lispify_predicate((int32_t)a<=(int32_t)b));
1029 r = lessp2(b, a);
1030 errexit();
1031 return onevalue(Lispify_predicate(!r));
1032 }
1033
1034 #endif /* COMMON */
1035
Lmax2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1036 Lisp_Object Lmax2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
1037 {
1038 CSLbool w;
1039 CSL_IGNORE(nil);
1040 push2(a, b);
1041 w = lessp2(a, b);
1042 pop2(b, a);
1043 errexit();
1044 if (w) return onevalue(b);
1045 else return onevalue(a);
1046 }
1047
Lmin2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1048 Lisp_Object Lmin2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
1049 {
1050 CSLbool w;
1051 CSL_IGNORE(nil);
1052 push2(a, b);
1053 w = lessp2(b, a);
1054 pop2(b, a);
1055 errexit();
1056 if (w) return onevalue(b);
1057 else return onevalue(a);
1058 }
1059
Lmax(Lisp_Object nil,int nargs,...)1060 Lisp_Object MS_CDECL Lmax(Lisp_Object nil, int nargs, ...)
1061 {
1062 va_list a;
1063 int i;
1064 Lisp_Object r;
1065 if (nargs < 1) return aerror("max");
1066 if (nargs > ARG_CUT_OFF) return aerror("too many args for max");
1067 va_start(a, nargs);
1068 push_args(a, nargs);
1069 stackcheck0(nargs);
1070 r = stack[1-nargs];
1071 for (i = 1; i<nargs; i++)
1072 { Lisp_Object s = stack[1+i-nargs];
1073 CSLbool fg;
1074 push2(r, s);
1075 fg = lessp2(r, s);
1076 pop2(s, r);
1077 nil = C_nil;
1078 if (exception_pending())
1079 { popv(nargs);
1080 return nil;
1081 }
1082 if (fg) r = s;
1083 }
1084 popv(nargs);
1085 return onevalue(r);
1086 }
1087
Lmin(Lisp_Object nil,int nargs,...)1088 Lisp_Object MS_CDECL Lmin(Lisp_Object nil, int nargs, ...)
1089 {
1090 va_list a;
1091 int i;
1092 Lisp_Object r;
1093 if (nargs < 1) return aerror("min");
1094 if (nargs > ARG_CUT_OFF) return aerror("too many args for min");
1095 va_start(a, nargs);
1096 push_args(a, nargs);
1097 stackcheck0(nargs);
1098 r = stack[1-nargs];
1099 for (i = 1; i<nargs; i++)
1100 { Lisp_Object s = stack[1+i-nargs];
1101 CSLbool fg;
1102 push2(r, s);
1103 fg = lessp2(s, r);
1104 pop2(s, r);
1105 nil = C_nil;
1106 if (exception_pending())
1107 { popv(nargs);
1108 return nil;
1109 }
1110 if (fg) r = s;
1111 }
1112 popv(nargs);
1113 return onevalue(r);
1114 }
1115
Lrational(Lisp_Object nil,Lisp_Object a)1116 Lisp_Object Lrational(Lisp_Object nil, Lisp_Object a)
1117 {
1118 a = rational(a);
1119 errexit();
1120 return onevalue(a);
1121 }
1122
1123 #ifdef COMMON
1124
Lmanexp(Lisp_Object nil,Lisp_Object a)1125 static Lisp_Object Lmanexp(Lisp_Object nil, Lisp_Object a)
1126 {
1127 int x;
1128 double f;
1129 if (! is_float(a)) aerror1("arg is not a floating-point number", a);
1130 f = float_of_number(a);
1131 f = frexp(f, &x);
1132 errexit();
1133 return onevalue(cons(make_boxfloat(f,TYPE_DOUBLE_FLOAT),
1134 fixnum_of_int(x)));
1135 }
1136
Lrationalize(Lisp_Object nil,Lisp_Object a)1137 static Lisp_Object Lrationalize(Lisp_Object nil, Lisp_Object a)
1138 {
1139 a = rationalize(a);
1140 errexit();
1141 return onevalue(a);
1142 }
1143 #endif
1144
1145 /*
1146 * The following random number generator is taken from the Norcroft
1147 * C library, but is included here so that random sequences will be
1148 * identical across all implementations of CSL, and because I have bad
1149 * and pessimistic expectations about the quality of random number
1150 * generators built into typical C libraries. That is not to say that
1151 * I ought not to be somewhat cynical about the code I have implemented
1152 * here! But it is tolerably fast and less dreadful than those old
1153 * 32-bit linear congruential mistakes. The initial values here
1154 * are a repeatable set of initial "random" values.
1155 */
1156
1157 static uint32_t random_number_seed[55] =
1158 {
1159 0x0d649239, 0x7c09f002, 0x6da2cd88, 0x969df534,
1160 0xfd7aca32, 0x16d89669, 0xc334a2fc, 0x0aba529c,
1161 0xdea5e90d, 0xdf06db3b, 0xf07d65eb, 0x74a5bf84,
1162 0x81e0b59e, 0xf2ac7c6c, 0x14339237, 0xb6b89675,
1163 0x61a66ca1, 0xa3fd9c3c, 0xed3ed908, 0xb4ffaf68,
1164 0xe43adf58, 0x6c108373, 0x14bbefe5, 0x20045563,
1165 0x8c54d44e, 0xd3470877, 0x5a8ae401, 0xa38c47fd,
1166 0x70ec616e, 0x3a8e3c82, 0x5bf48b37, 0x98d07ad8,
1167 0x6753e8c1, 0xc120d571, 0x7d308c18, 0x014ef96d,
1168 0x7aae7f25, 0x817e97c8, 0x8127a883, 0x1f88de19,
1169 0x68c2f294, 0x394ea2dd, 0x2f475077, 0x1fbea2a6,
1170 0x6e943040, 0xfa736fbb, 0x89e5fc31, 0xca16186e,
1171 0x720e8da7, 0xd8c0b092, 0xb340e967, 0x6e0ba043,
1172 0x1250d232, 0x061a9e86, 0xaa710c75
1173 };
1174
1175 static int random_j = 23, random_k = 54;
1176
1177 static CSLbool randomization_request = NO;
1178
1179 /*
1180 * If the user specifies a random number seed of zero I will try to
1181 * start things in as unpredictable a state as I reasonably can. To
1182 * achieve this I will update a block of unpredictable data at a
1183 * number of points during a CSL run, garnering incremental amounts
1184 * of fairly low grade "randomness" from timing information and the
1185 * memory addresses that get allocated to CSL. Because it will take
1186 * a while for such information to build up I arrange that specifying
1187 * a random seed of zero does not do anything at once (and in particular
1188 * the implicit call of this nature when CSL starts does not do much),
1189 * but the unpredictable mess I accumulate is inspected the first time
1190 * any user actually asks for a random value. Since user keyboard input
1191 * contributes to the clutter it could be that a cautious user will ask the
1192 * user to type in a long string of gibberish before asking for any
1193 * random numbers, and the gibberish typed will then in fact form part
1194 * of the seed that will be used. On Windows I can hook in and make
1195 * mouse activity etc contribute to the seed too.
1196 */
1197
randomize(void)1198 static void randomize(void)
1199 {
1200 int i;
1201 random_j = 23;
1202 random_k = 54;
1203 for (i=20; i<48; i+=4)
1204 { CSL_MD5_Init();
1205 CSL_MD5_Update(unpredictable, sizeof(unpredictable));
1206 CSL_MD5_Final((unsigned char *)&random_number_seed[i]);
1207 inject_randomness((int)time(NULL));
1208 }
1209 /*
1210 * Note that I do not initialise the whole array of seed values here.
1211 * Leaving something over can count as part of the unpredictability! But I
1212 * do try to put in mess through the parts of the seed that will be used
1213 * first so that any obvious patterns will get clobbered.
1214 */
1215 random_number_seed[0] |= 1;
1216 randomization_request = NO;
1217 }
1218
Crand(void)1219 uint32_t Crand(void)
1220 {
1221 /*
1222 * See Knuth vol 2 section 3.2.2 for a discussion of this random
1223 * number generator.
1224 */
1225 uint32_t temp;
1226 if (randomization_request) randomize();
1227 temp = (random_number_seed[random_k] += random_number_seed[random_j]);
1228 if (--random_j < 0) random_j = 54, --random_k;
1229 else if (--random_k < 0) random_k = 54;
1230 return temp;
1231 }
1232
Csrand(uint32_t seed,uint32_t seed2)1233 void Csrand(uint32_t seed, uint32_t seed2)
1234 {
1235 /*
1236 * This allows you to put 64 bits of seed into the random sequence,
1237 * but it is very improbable that you have any good source of randomness
1238 * that good to start with! The input seeds are scrambled using md5
1239 * and then rather crudely widened to fill the whole array of seed data.
1240 * If the seed is specified as (0,0) then I will initialise things using
1241 * information from the time of day and the clock. This is NOT very
1242 * good, especially since I only use portable C-library ways of reading
1243 * the time. But it will at least not repeat for any single user and
1244 * since the clock information is then scrambled via md5 it will APPEAR
1245 * fairly unpredictable.
1246 */
1247 int i;
1248 unsigned char seedv[16], *p;
1249 random_j = 23;
1250 random_k = 54;
1251 i = 0;
1252 if (seed == 0 && seed2 == 0)
1253 { randomization_request = YES;
1254 return;
1255 }
1256 randomization_request = NO;
1257 /*
1258 * This version was byte-order sensitive, but documents the idea
1259 * that I first had.
1260 * random_number_seed[0] = seed;
1261 * random_number_seed[1] = 0x12345678;
1262 * random_number_seed[2] = 0xa7086dee;
1263 * random_number_seed[3] = seed2;
1264 * then I used the first 16 bytes of random_number_seed as input to md5.
1265 */
1266 seedv[0] = (seed & 0xff);
1267 seedv[1] = ((seed >> 8) & 0xff);
1268 seedv[2] = ((seed >> 16) & 0xff);
1269 seedv[3] = ((seed >> 24) & 0xff);
1270 seedv[4] = 0x78;
1271 seedv[5] = 0x56;
1272 seedv[6] = 0x34;
1273 seedv[7] = 0x12;
1274 seedv[8] = 0xee;
1275 seedv[9] = 0x6d;
1276 seedv[10] = 0x08;
1277 seedv[11] = 0xa7;
1278 seedv[12] = (seed2 & 0xff);
1279 seedv[13] = ((seed2 >> 8) & 0xff);
1280 seedv[14] = ((seed2 >> 16) & 0xff);
1281 seedv[15] = ((seed2 >> 24) & 0xff);
1282 #ifdef TRACE_RANDOM
1283 for (i=0; i<16; i++) term_printf("%.2x ", seedv[i]);
1284 term_printf("\n");
1285 #endif
1286 /*
1287 * Next I will scramble the seed data that I have been given using md5
1288 * and place the resulting 128 bits of digested stuff in the start of
1289 * the seed vector.
1290 */
1291 CSL_MD5_Init();
1292 CSL_MD5_Update(seedv, 16);
1293 CSL_MD5_Final((unsigned char *)&random_number_seed[0]);
1294 /*
1295 * The remainder of the vector gets filled using a simple linear
1296 * congruential scheme. Note that MD5 filled in BYTES andy what I need next
1297 * is an INTEGER, so to be byte-order insensitive I need to do things
1298 * the long way.
1299 */
1300 i = 4;
1301 /*
1302 * Does anybody want to think about "strict alisasing" and the next little
1303 * fragment of code? Ha Ha.
1304 */
1305 p = (unsigned char *)random_number_seed;
1306 seed = p[0] | (p[1]<<8) | (p[2]<<16) | (p[3]<<24);
1307 random_number_seed[0] = seed;
1308 random_number_seed[1] = p[4] | (p[5]<<8) | (p[6]<<16) | (p[7]<<24);
1309 random_number_seed[2] = p[8] | (p[9]<<8) | (p[10]<<16) | (p[11]<<24);
1310 random_number_seed[3] = p[12] | (p[13]<<8) | (p[14]<<16) | (p[15]<<24);
1311 while (i<55)
1312 { seed = 69069*seed + 1725307361; /* computed modulo 2^32 */
1313 random_number_seed[i++] = seed;
1314 }
1315 /*
1316 * I would like to make the least significant bits a little less
1317 * regular even to start with, so I xor in from one of the words that
1318 * md5 gave me.
1319 */
1320 seed = random_number_seed[1];
1321 i = 55-30;
1322 while (i<55)
1323 { random_number_seed[i++] ^= seed & 1;
1324 seed = seed >> 1;
1325 }
1326 /*
1327 * If all the least significant bits were zero to start with they would
1328 * always stay that way, so I force one of them to be 1.
1329 */
1330 random_number_seed[21] |= 1;
1331 #ifdef TRACE_RANDOM
1332 for (i=0; i<55; i++) term_printf("%2d %.8x\n", i, random_number_seed[i]);
1333 #endif
1334 }
1335
1336 #ifdef COMMON
Lrandom_2(Lisp_Object nil,Lisp_Object a,Lisp_Object bb)1337 Lisp_Object Lrandom_2(Lisp_Object nil, Lisp_Object a, Lisp_Object bb)
1338 {
1339 Lisp_Object b;
1340 /*
1341 * Common Lisp expects an optional second arg to be used for the random
1342 * state - at present I do not support that, but it will not be too hard
1343 * when I get around to it...
1344 */
1345 b = bb;
1346 CSL_IGNORE(nil);
1347 if (is_fixnum(a))
1348 { int32_t v = int_of_fixnum(a), p, q;
1349 if (v <= 0) return aerror1("random", a);
1350 /* (random 1) always returns zero - a rather silly case! */
1351 else if (v == 1) return onevalue(fixnum_of_int(0));
1352 /*
1353 * I generate a value that is an exact multiple of my range (v) and
1354 * pick random bitpatterns until I find one less than that. On average
1355 * I will have only VERY slightly less than one draw needed, and doing things
1356 * this way ought to ensure that my pseudo random numbers are uniformly
1357 * distributed provided that the underlying generator is well behaved.
1358 */
1359 p = v*(0x7fffffff/v);
1360 do q = ((uint32_t)Crand()) >> 1; while (q > p);
1361 return onevalue(fixnum_of_int(q % v));
1362 }
1363 if (is_numbers(a))
1364 { int32_t len, len1, msd;
1365 uint32_t w, w1;
1366 Lisp_Object r;
1367 if (!is_bignum(a)) return aerror1("random", a);
1368 len = bignum_length(a);
1369 push(a);
1370 r = getvector(TAG_NUMBERS, TYPE_BIGNUM, len);
1371 pop(a);
1372 errexit();
1373 len1 = (len-CELL)/4-1;
1374 restart:
1375 len = len1;
1376 msd = bignum_digits(a)[len];
1377 if (msd < 0) return aerror("negative arg for random"); /* -ve arg */
1378 if (msd == 0)
1379 { bignum_digits(r)[len] = 0;
1380 len--;
1381 msd = bignum_digits(a)[len];
1382 }
1383 for (;;)
1384 { w = (0xffffffffU/((uint32_t)msd+1U))*((uint32_t)msd+1U);
1385 do w1 = (uint32_t)Crand(); while (w1 >= w);
1386 w1 = w1%((uint32_t)msd+1U);
1387 bignum_digits(r)[len] = w1;
1388 if ((int32_t)w1 != msd) break;
1389 /*
1390 * The loop to restart on the next line is when the random value I
1391 * have built up word by word ends up being equal to the input number - I
1392 * will discard it and start again in that case.
1393 */
1394 if (len == 0) goto restart;
1395 len--;
1396 msd = bignum_digits(a)[len];
1397 }
1398 /*
1399 * having got some leading digits properly set up I can fill in the rest
1400 * as totally independent bit-patterns.
1401 */
1402 for (len--;len>=0; len--)
1403 bignum_digits(r)[len] = ((uint32_t)Crand())>>1;
1404 return onevalue(shrink_bignum(r, len1));
1405 }
1406 if (is_bfloat(a))
1407 { Header h = flthdr(a);
1408 double d = float_of_number(a), v;
1409 /*
1410 * The calculation here turns 62 bits of integer data into a floating
1411 * point number in the range 0.0 (inclusive) to 1.0 (exclusive). Well,
1412 * to be more precise, rounding the value to the machine's floating point
1413 * format may round it up to be exactly 1.0, so I discard and cases where
1414 * that happens (once in several blue moons...). If I wrote code that
1415 * knew exactly how many bits my floating point format had I could avoid
1416 * the need for that extra test, but it does not seem very painful to me
1417 * and I prefer the more portable code.
1418 */
1419 do
1420 { v = ((double)(int32_t)(Crand() & 0x7fffffff)) / TWO_31;
1421 v += (double)(int32_t)(Crand() & 0x7fffffff);
1422 v /= TWO_31;
1423 v *= d;
1424 } while (v == d);
1425 a = make_boxfloat(v, type_of_header(h));
1426 errexit();
1427 return onevalue(a);
1428 }
1429 if (is_sfloat(a))
1430 { Float_union d;
1431 float v;
1432 d.i = a - TAG_SFLOAT;
1433 /*
1434 * similar idea to boxfloat case, but only 31 bits randomness used.
1435 * SOFTWARE_FLOATING_POINT conversion needed here, maybe
1436 */
1437 do
1438 { v = (float)(int32_t)(Crand() & 0x7fffffff)/(float)TWO_31;
1439 v = v*d.f;
1440 } while (v == d.f);
1441 d.f = v;
1442 return onevalue((d.i & ~(int32_t)0xf) + TAG_SFLOAT);
1443 }
1444 return aerror1("random", a);
1445 }
1446 #endif
1447
Lrandom(Lisp_Object nil,Lisp_Object a)1448 Lisp_Object Lrandom(Lisp_Object nil, Lisp_Object a)
1449 {
1450 CSL_IGNORE(nil);
1451 if (is_fixnum(a))
1452 { int32_t v = int_of_fixnum(a), p, q;
1453 if (v <= 0) return aerror1("random", a);
1454 /* (random 1) always returns zero - a rather silly case! */
1455 else if (v == 1) return onevalue(fixnum_of_int(0));
1456 /*
1457 * I generate a value that is an exact multiple of my range (v) and
1458 * pick random bitpatterns until I find one less than that. On average
1459 * I will have only VERY slightly less than one draw needed, and doing things
1460 * this way ought to ensure that my pseudo random numbers are uniformly
1461 * distributed provided that the underlying generator is well behaved.
1462 */
1463 p = v*(0x7fffffff/v);
1464 do q = ((uint32_t)Crand()) >> 1; while (q > p);
1465 return onevalue(fixnum_of_int(q % v));
1466 }
1467 if (is_numbers(a))
1468 { int32_t len, len1, msd;
1469 uint32_t w, w1;
1470 Lisp_Object r;
1471 if (!is_bignum(a)) return aerror1("random", a);
1472 len = bignum_length(a);
1473 push(a);
1474 r = getvector(TAG_NUMBERS, TYPE_BIGNUM, len);
1475 pop(a);
1476 errexit();
1477 len1 = (len-CELL)/4-1;
1478 restart:
1479 len = len1;
1480 msd = bignum_digits(a)[len];
1481 if (msd < 0) return aerror("negative arg for random"); /* -ve arg */
1482 if (msd == 0)
1483 { bignum_digits(r)[len] = 0;
1484 len--;
1485 msd = bignum_digits(a)[len];
1486 }
1487 for (;;)
1488 { w = (0xffffffffU/((uint32_t)msd+1U))*((uint32_t)msd+1U);
1489 do w1 = (uint32_t)Crand(); while (w1 >= w);
1490 w1 = w1%((uint32_t)msd+1U);
1491 bignum_digits(r)[len] = w1;
1492 if ((int32_t)w1 != msd) break;
1493 /*
1494 * The loop to restart on the next line is when the random value I
1495 * have built up word by word ends up being equal to the input number - I
1496 * will discard it and start again in that case.
1497 */
1498 if (len == 0) goto restart;
1499 len--;
1500 msd = bignum_digits(a)[len];
1501 }
1502 /*
1503 * having got some leading digits properly set up I can fill in the rest
1504 * as totally independent bit-patterns.
1505 */
1506 for (len--;len>=0; len--)
1507 bignum_digits(r)[len] = ((uint32_t)Crand())>>1;
1508 return onevalue(shrink_bignum(r, len1));
1509 }
1510 if (is_bfloat(a))
1511 { Header h = flthdr(a);
1512 double d = float_of_number(a), v;
1513 /*
1514 * The calculation here turns 62 bits of integer data into a floating
1515 * point number in the range 0.0 (inclusive) to 1.0 (exclusive). Well,
1516 * to be more precise, rounding the value to the machine's floating point
1517 * format may round it up to be exactly 1.0, so I discard and cases where
1518 * that happens (once in several blue moons...). If I wrote code that
1519 * knew exactly how many bits my floating point format had I could avoid
1520 * the need for that extra test, but it does not seem very painful to me
1521 * and I prefer the more portable code.
1522 */
1523 do
1524 { v = ((double)(int32_t)(Crand() & 0x7fffffff)) / TWO_31;
1525 v += (double)(int32_t)(Crand() & 0x7fffffff);
1526 v /= TWO_31;
1527 v *= d;
1528 } while (v == d);
1529 a = make_boxfloat(v, type_of_header(h));
1530 errexit();
1531 return onevalue(a);
1532 }
1533 #ifdef COMMON
1534 if (is_sfloat(a))
1535 { Float_union d;
1536 float v;
1537 d.i = a - TAG_SFLOAT;
1538 /*
1539 * similar idea to boxfloat case, but only 31 bits randomness used.
1540 * SOFTWARE_FLOATING_POINT conversion needed here, maybe
1541 */
1542 do
1543 { v = (float)(int32_t)(Crand() & 0x7fffffff)/(float)TWO_31;
1544 v = v*d.f;
1545 } while (v == d.f);
1546 d.f = v;
1547 return onevalue((d.i & ~(int32_t)0xf) + TAG_SFLOAT);
1548 }
1549 #endif
1550 return aerror1("random", a);
1551 }
1552
Lnext_random(Lisp_Object nil,int nargs,...)1553 Lisp_Object MS_CDECL Lnext_random(Lisp_Object nil, int nargs, ...)
1554 /*
1555 * Returns a random positive fixnum. 27 bits in this Lisp!
1556 */
1557 {
1558 int32_t r;
1559 argcheck(nargs, 0, "next-random");
1560 CSL_IGNORE(nil);
1561 r = Crand();
1562 return onevalue((Lisp_Object)((r & 0x7ffffff0) + TAG_FIXNUM));
1563 }
1564
Lmake_random_state(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1565 Lisp_Object Lmake_random_state(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
1566 {
1567 /*
1568 * Nasty temporary hack here to allow me to set the seed for the
1569 * random number generator in Standard Lisp mode. I need to re-think
1570 * this soon before it feels frozen in! Oops - too late!!!
1571 */
1572 CSL_IGNORE(b);
1573 if (!is_fixnum(a)) return aerror1("make-random-state", a);
1574 Csrand(int_of_fixnum(a),
1575 is_fixnum(b) ? int_of_fixnum(b) : 0);
1576 return onevalue(nil);
1577 }
1578
Lmake_random_state1(Lisp_Object nil,Lisp_Object a)1579 Lisp_Object Lmake_random_state1(Lisp_Object nil, Lisp_Object a)
1580 {
1581 if (!is_fixnum(a)) return aerror1("make-random-state", a);
1582 Csrand(int_of_fixnum(a), 0);
1583 return onevalue(nil);
1584 }
1585
1586 /*
1587 * The function md5() can be given a number or a string as an argument,
1588 * and it uses the md5 message digest algorithm to reduce it to a
1589 * numeric value in the range 0 to 2^128.
1590 * Well actually I will also allow an arbitrary expression, which I
1591 * will treat as if it has to be printed...
1592 */
1593
Lmd5(Lisp_Object env,Lisp_Object a)1594 Lisp_Object Lmd5(Lisp_Object env, Lisp_Object a)
1595 {
1596 Lisp_Object nil = C_nil;
1597 Lisp_Object r;
1598 unsigned char md[16];
1599 uint32_t v0, v1, v2, v3, v4;
1600 int32_t len, i;
1601 CSL_IGNORE(env);
1602 if (is_fixnum(a))
1603 { sprintf((char *)md, "%.8lx", (unsigned long)a);
1604 CSL_MD5_Init();
1605 CSL_MD5_Update(md, 8);
1606 }
1607 else if (is_numbers(a) && is_bignum_header(numhdr(a)))
1608 { len = length_of_header(numhdr(a));
1609 CSL_MD5_Init();
1610 for (i=CELL; i<len; i+=4)
1611 { sprintf((char *)md, "%.8lx", (unsigned long)bignum_digits(a)[(i-CELL)/4]);
1612 CSL_MD5_Update(md, 8);
1613 }
1614 }
1615 else if (is_vector(a) && type_of_header(vechdr(a)) == TYPE_STRING)
1616 { len = length_of_header(vechdr(a));
1617 CSL_MD5_Init();
1618 CSL_MD5_Update((unsigned char *)(a + CELL - TAG_VECTOR), len-CELL);
1619 }
1620 else checksum(a);
1621 CSL_MD5_Final(md);
1622 v0 = md[0] + (md[1]<<8) + (md[2]<<16) + (md[3]<<24);
1623 v1 = md[4] + (md[5]<<8) + (md[6]<<16) + (md[7]<<24);
1624 v2 = md[8] + (md[9]<<8) + (md[10]<<16) + (md[11]<<24);
1625 v3 = md[12] + (md[13]<<8) + (md[14]<<16) + (md[15]<<24);
1626 v4 = v3 >> 28;
1627 v3 = ((v3 << 3) | (v2 >> 29)) & 0x7fffffff;
1628 v2 = ((v2 << 2) | (v1 >> 30)) & 0x7fffffff;
1629 v1 = ((v1 << 1) | (v0 >> 31)) & 0x7fffffff;
1630 v0 &= 0x7fffffff;
1631 /*
1632 * Note the funny tests. This is because in my representation the
1633 * top word of a bignum is a 2s complement signed value and to keep clear
1634 * of overflow that means I use an extra digit slightly before one might
1635 * imagine it is necessary!
1636 */
1637 if (v4 != 0 || (v3 & 0x40000000) != 0) len = CELL+20;
1638 else if (v3 != 0 || (v2 & 0x40000000) != 0) len = CELL+16;
1639 else if (v2 != 0 || (v1 & 0x40000000) != 0) len = CELL+12;
1640 else if (v1 != 0 || (v0 & 0x40000000) != 0) len = CELL+8;
1641 else if ((v0 & fix_mask) != 0) len = CELL+4;
1642 else return onevalue(fixnum_of_int(v0));
1643 r = getvector(TAG_NUMBERS, TYPE_BIGNUM, len);
1644 errexit();
1645 if (SIXTY_FOUR_BIT)
1646 { switch (len)
1647 {
1648 case CELL+20:
1649 bignum_digits(r)[5] = 0; /* zeros out padding word as necessary */
1650 bignum_digits(r)[4] = v4;
1651 case CELL+16:
1652 case CELL+12:
1653 bignum_digits(r)[3] = v3;
1654 bignum_digits(r)[2] = v2;
1655 case CELL+8:
1656 case CELL+4:
1657 bignum_digits(r)[1] = v1;
1658 bignum_digits(r)[0] = v0;
1659 break;
1660 }
1661 }
1662 else
1663 { switch (len)
1664 {
1665 case CELL+20:
1666 case CELL+16:
1667 bignum_digits(r)[4] = v4; /* zeros out padding word as necessary */
1668 bignum_digits(r)[3] = v3;
1669 case CELL+12:
1670 case CELL+8:
1671 bignum_digits(r)[2] = v2;
1672 bignum_digits(r)[1] = v1;
1673 case CELL+4:
1674 bignum_digits(r)[0] = v0;
1675 break;
1676 }
1677 }
1678 /* validate_number("MD5", r, r, r); */
1679 return onevalue(r);
1680 }
1681
1682 /*
1683 * md60 is a function that uses MD5 but then returns just about 60 bits
1684 * of number not 128. It is for use when the full 128 bits of checksum
1685 * would be clumsy overkill.
1686 */
1687
Lmd60(Lisp_Object env,Lisp_Object a)1688 Lisp_Object Lmd60(Lisp_Object env, Lisp_Object a)
1689 {
1690 Lisp_Object nil = C_nil;
1691 Lisp_Object r;
1692 unsigned char md[16];
1693 uint32_t v0, v1;
1694 int32_t len, i;
1695 CSL_IGNORE(env);
1696 if (is_fixnum(a))
1697 { sprintf((char *)md, "%.8lx", (unsigned long)a);
1698 CSL_MD5_Init();
1699 CSL_MD5_Update(md, 8);
1700 }
1701 else if (is_numbers(a) && is_bignum_header(numhdr(a)))
1702 { len = length_of_header(numhdr(a));
1703 CSL_MD5_Init();
1704 for (i=CELL; i<len; i+=4)
1705 { sprintf((char *)md, "%.8lx", (unsigned long)bignum_digits(a)[(i-CELL)/4]);
1706 CSL_MD5_Update(md, 8);
1707 }
1708 }
1709 else if (is_vector(a) && type_of_header(vechdr(a)) == TYPE_STRING)
1710 { len = length_of_header(vechdr(a));
1711 CSL_MD5_Init();
1712 CSL_MD5_Update((unsigned char *)(a + CELL - TAG_VECTOR), len-CELL);
1713 }
1714 else checksum(a);
1715 CSL_MD5_Final(md);
1716 v0 = md[0] + (md[1]<<8) + (md[2]<<16) + (md[3]<<24);
1717 v1 = md[4] + (md[5]<<8) + (md[6]<<16) + (md[7]<<24);
1718 v1 = ((v1 << 1) | (v0 >> 31)) & 0x3fffffff;
1719 v0 &= 0x7fffffff;
1720 if (v1 != 0 || (v0 & 0x40000000) != 0) len = CELL+8;
1721 #ifdef PERMIT_SHORT_CHECKSUMS
1722 else if ((v0 & fix_mask) != 0) len = CELL+4;
1723 else return onevalue(fixnum_of_int(v0));
1724 #else
1725 else
1726 {
1727 /*
1728 * Here I ensure that the checksum that I return is a 2-word bignum.
1729 * This SKEWS the distribution somewhat, in that results lower than 2^30
1730 * will never be returned. In the very unusual case that the low 61 bits
1731 * of md5 were all zero I return a somewhat arbitrary alternative value.
1732 */
1733 if (v0 != 0)
1734 { v1 = v0;
1735 v0 = md[8] + (md[9]<<8) + (md[10]<<16) + (md[11]<<24);
1736 v0 &= 0x7fffffff;
1737 len = CELL+8;
1738 }
1739 else
1740 { v1 = 0x12345678;
1741 len = CELL+8;
1742 }
1743 }
1744 #endif
1745 r = getvector(TAG_NUMBERS, TYPE_BIGNUM, len);
1746 errexit();
1747 if (SIXTY_FOUR_BIT)
1748 { bignum_digits(r)[1] = v1;
1749 bignum_digits(r)[0] = v0;
1750 }
1751 else
1752 { switch (len)
1753 {
1754 case CELL+8:
1755 bignum_digits(r)[2] = 0;
1756 bignum_digits(r)[1] = v1;
1757 case CELL+4:
1758 bignum_digits(r)[0] = v0;
1759 break;
1760 }
1761 }
1762 /* validate_number("MD60", r, r, r); */
1763 return onevalue(r);
1764 }
1765
Llogand2(Lisp_Object env,Lisp_Object a1,Lisp_Object a2)1766 static Lisp_Object Llogand2(Lisp_Object env, Lisp_Object a1, Lisp_Object a2)
1767 {
1768 return Lboolfn(env, 2, a1, a2);
1769 }
1770
Llogeqv2(Lisp_Object env,Lisp_Object a1,Lisp_Object a2)1771 static Lisp_Object Llogeqv2(Lisp_Object env, Lisp_Object a1, Lisp_Object a2)
1772 {
1773 return Lboolfn(env, 2, a1, a2);
1774 }
1775
Llogxor2(Lisp_Object env,Lisp_Object a1,Lisp_Object a2)1776 static Lisp_Object Llogxor2(Lisp_Object env, Lisp_Object a1, Lisp_Object a2)
1777 {
1778 return Lboolfn(env, 2, a1, a2);
1779 }
1780
Llogor2(Lisp_Object env,Lisp_Object a1,Lisp_Object a2)1781 static Lisp_Object Llogor2(Lisp_Object env, Lisp_Object a1, Lisp_Object a2)
1782 {
1783 return Lboolfn(env, 2, a1, a2);
1784 }
1785
1786 setup_type const arith06_setup[] =
1787 {
1788 {"ash", too_few_2, Lash, wrong_no_2},
1789 {"ash1", too_few_2, Lash1, wrong_no_2},
1790 {"divide", too_few_2, Ldivide, wrong_no_2},
1791 {"evenp", Levenp, too_many_1, wrong_no_1},
1792 {"inorm", too_few_2, Linorm, wrong_no_2},
1793 {"logand", Lidentity, Llogand2, Lboolfn},
1794 {"logeqv", Lidentity, Llogeqv2, Lboolfn},
1795 {"lognot", Llognot, too_many_1, wrong_no_1},
1796 {"logxor", Lidentity, Llogxor2, Lboolfn},
1797 {"lsd", Llsd, too_many_1, wrong_no_1},
1798 {"make-random-state", Lmake_random_state1, Lmake_random_state, wrong_no_2},
1799 {"max", Lidentity, Lmax2, Lmax},
1800 {"max2", too_few_2, Lmax2, wrong_no_2},
1801 {"min", Lidentity, Lmin2, Lmin},
1802 {"min2", too_few_2, Lmin2, wrong_no_2},
1803 {"minus", Lminus, too_many_1, wrong_no_1},
1804 {"minusp", Lminusp, too_many_1, wrong_no_1},
1805 {"mod", too_few_2, Lmod, wrong_no_2},
1806 {"msd", Lmsd, too_many_1, wrong_no_1},
1807 {"oddp", Loddp, too_many_1, wrong_no_1},
1808 {"onep", Lonep, too_many_1, wrong_no_1},
1809 {"plus2", too_few_2, Lplus2, wrong_no_2},
1810 {"plusp", Lplusp, too_many_1, wrong_no_1},
1811 {"rational", Lrational, too_many_1, wrong_no_1},
1812 {"times2", too_few_2, Ltimes2, wrong_no_2},
1813 {"zerop", Lzerop, too_many_1, wrong_no_1},
1814 {"md5", Lmd5, too_many_1, wrong_no_1},
1815 {"md60", Lmd60, too_many_1, wrong_no_1},
1816 #ifdef COMMON
1817 {"*", Lidentity, Ltimes2, Ltimes},
1818 {"+", Lidentity, Lplus2, Lplus},
1819 {"-", Lminus, Ldifference2, Ldifference},
1820 {"/", Lquotient_1, Lquotient, Lquotient_n},
1821 {"/=", Lneq_1, Lneq_2, Lneqn},
1822 {"1+", Ladd1, too_many_1, wrong_no_1},
1823 {"1-", Lsub1, too_many_1, wrong_no_1},
1824 {"<", Llessp_1, Llessp, Llessp_n},
1825 {"<=", Lleq_1, Lleq, Lleq_n},
1826 {"=", Leqn_1, Leqn, Leqn_n},
1827 {">", Lgreaterp_1, Lgreaterp, Lgreaterp_n},
1828 {">=", Lgeq_1, Lgeq, Lgeq_n},
1829 {"float", Lfloat, Lfloat_2, wrong_no_1},
1830 {"logior", Lidentity, Llogor2, Lboolfn},
1831 {"random", Lrandom, Lrandom_2, wrong_no_1},
1832 {"rationalize", Lrationalize, too_many_1, wrong_no_1},
1833 {"manexp", Lmanexp, too_many_1, wrong_no_1},
1834 {"rem", too_few_2, Lrem, wrong_no_2},
1835 /*
1836 * I also provide the old style names to make porting code easier for me
1837 */
1838 {"times", Lidentity, Ltimes2, Ltimes},
1839 {"plus", Lidentity, Lplus2, Lplus},
1840 {"times2", too_few_2, Ltimes2, wrong_no_2},
1841 {"plus2", too_few_2, Lplus2, wrong_no_2},
1842 {"minus", Lminus, too_many_1, wrong_no_1},
1843 {"difference", too_few_2, Ldifference2, Ldifference},
1844 /* I leave QUOTIENT as the integer-truncating form, while "/" gives ratios */
1845 {"quotient", too_few_2, LSLquotient, wrong_no_2},
1846 {"remainder", too_few_2, Lrem, wrong_no_2},
1847 {"add1", Ladd1, too_many_1, wrong_no_1},
1848 {"sub1", Lsub1, too_many_1, wrong_no_1},
1849 {"lessp", Llessp_1, Llessp, Llessp_n},
1850 {"leq", Lleq_1, Lleq, Lleq_n},
1851 {"eqn", Leqn_1, Leqn, Leqn_n},
1852 {"greaterp", Lgreaterp_1, Lgreaterp, Lgreaterp_n},
1853 {"geq", Lgeq_1, Lgeq, Lgeq_n},
1854 {"next-random-number", wrong_no_0a, wrong_no_0b, Lnext_random},
1855 {"logor", Lidentity, Llogor2, Lboolfn},
1856 #else
1857 {"add1", Ladd1, too_many_1, wrong_no_1},
1858 {"difference", too_few_2, Ldifference2, wrong_no_2},
1859 {"eqn", too_few_2, Leqn, wrong_no_2},
1860 {"float", Lfloat, too_many_1, wrong_no_1},
1861 {"geq", too_few_2, Lgeq, wrong_no_2},
1862 {"greaterp", too_few_2, Lgreaterp, wrong_no_2},
1863 {"leq", too_few_2, Lleq, wrong_no_2},
1864 {"lessp", too_few_2, Llessp, wrong_no_2},
1865 {"logor", Lidentity, Llogor2, Lboolfn},
1866 {"quotient", too_few_2, Lquotient, wrong_no_2},
1867 /*
1868 * I used to call these just random and next-random-number, but REDUCE
1869 * wants its own versions of those (for cross-Lisp consistency) so I use
1870 * alternative names here.
1871 */
1872 {"random-number", Lrandom, too_many_1, wrong_no_1},
1873 {"random-fixnum", wrong_no_0a, wrong_no_0b, Lnext_random},
1874 {"remainder", too_few_2, Lrem, wrong_no_2},
1875 {"sub1", Lsub1, too_many_1, wrong_no_1},
1876 #endif
1877 {NULL, 0, 0, 0}
1878 };
1879
1880 /* end of arith06.c */
1881
1882