Artifact fdfbe50a814d5cec256ffec0b265f3b077738da612f44dc3738ff52d011a0199:
- Executable file
r37/lisp/csl/cslbase/arith06.c
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 56836) [annotate] [blame] [check-ins using] [more...]
/* arith06.c Copyright (C) 1990-2002 Codemist Ltd */ /* * Arithmetic functions... lots of Lisp entrypoints. * note that for CSL I want plus and times to be special forms. */ /* * This code may be used and modified, and redistributed in binary * or source form, subject to the "CCL Public License", which should * accompany it. This license is a variant on the BSD license, and thus * permits use of code derived from this in either open and commercial * projects: but it does require that updates to this code be made * available back to the originators of the package. * Before merging other code in with this or linking this code * with other packages or libraries please check that the license terms * of the other material are compatible with those of this. */ /* Signature: 1e60864f 10-Oct-2002 */ #include <stdarg.h> #include <string.h> #include <ctype.h> #include <math.h> #include "machine.h" #include "tags.h" #include "cslerror.h" #include "externs.h" #include "arith.h" #include "entries.h" #ifdef TIMEOUT #include "timeout.h" #endif /*****************************************************************************/ /*** Lisp-callable versions of arithmetic functions ***/ /*****************************************************************************/ Lisp_Object Ladd1(Lisp_Object nil, Lisp_Object a) { if (is_fixnum(a)) { unsigned32 r = (unsigned32)a + 0x10; /* fixnums have data shifted left 4 bits */ if (r == ~0x7ffffffe) /* The ONLY possible overflow case here */ a = make_one_word_bignum(1 + int_of_fixnum(a)); else return onevalue((Lisp_Object)r); /* the cheap case */ } else a = plus2(a, fixnum_of_int(1)); errexit(); return onevalue(a); } Lisp_Object Lsub1(Lisp_Object nil, Lisp_Object a) { if (is_fixnum(a)) { if (a == ~0x7ffffffe) /* The ONLY possible overflow case here */ return make_one_word_bignum(int_of_fixnum(a) - 1); else return onevalue((Lisp_Object)(a - 0x10)); } else a = plus2(a, fixnum_of_int(-1)); errexit(); return onevalue(a); } #ifdef COMMON Lisp_Object Lfloat_2(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSL_IGNORE(nil); if (is_sfloat(b)) { double d = float_of_number(a); return onevalue(make_sfloat(d)); } else if (!is_bfloat(b)) return aerror1("bad arg for float", b); else { double d = float_of_number(a); return onevalue(make_boxfloat(d, type_of_header(flthdr(b)))); } } #endif Lisp_Object Lfloat(Lisp_Object nil, Lisp_Object a) { double d; CSL_IGNORE(nil); if (!is_number(a)) return aerror1("bad arg for float", a); d = float_of_number(a); #ifdef COMMON /* Do we REALLY want single precision by default here? */ return onevalue(make_boxfloat(d, TYPE_SINGLE_FLOAT)); #else return onevalue(make_boxfloat(d, TYPE_DOUBLE_FLOAT)); #endif } Lisp_Object Llognot(Lisp_Object nil, Lisp_Object a) { a = lognot(a); errexit(); return onevalue(a); } Lisp_Object Lash(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { a = ash(a, b); errexit(); return onevalue(a); } Lisp_Object Lash1(Lisp_Object nil, Lisp_Object a, Lisp_Object b) /* * This function multiplies or divides by a power of two. Note that * this corresponds to natural shifts on a sign-and-magnitude machine, * but is not an "arithmetic" shift as that term is understood on * 2's complement machines. */ { CSLbool negative = NO; if (!is_fixnum(b)) return aerror("ash1"); if (minusp(a)) { negative = YES; a = negate(a); } errexit(); a = ash(a, b); errexit(); if (negative) { a = negate(a); errexit(); } return onevalue(a); } static int msd_table[256] = { 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8 }; Lisp_Object Lmsd(Lisp_Object nil, Lisp_Object a) { int32 top; int32 r = 0; CSL_IGNORE(nil); if (is_fixnum(a)) top = int_of_fixnum(a); else if (is_numbers(a)) { Header h = numhdr(a); if (!is_bignum_header(h)) return aerror1("bad arg for msd", a); r = (length_of_header(h)-CELL)/4 - 1; top = bignum_digits(a)[r]; r = 31*r; } else return aerror1("bad arg for msd", a); if (top < 0) return aerror1("negative arg for msd", a); /* -ve arg */ /* * Note that top may be zero here, but in that case the next word down of * the bignum involved MUST be fully normalised with its top bit set. * The effect of this code is that I return (msd 0) => 0. */ if (top >= 0x10000) r += 16, top >>= 16; if (top >= 0x100) r += 8, top >>= 8; return onevalue(fixnum_of_int(r + msd_table[top])); } static int lsd_table[256] = { 8, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0 }; Lisp_Object Llsd(Lisp_Object nil, Lisp_Object a) { int32 top; int32 r = 0; CSL_IGNORE(nil); if (is_fixnum(a)) { top = int_of_fixnum(a); /* lsd(0) is taken to have the value 0 here - it is a bit of an odd case */ if (top == 0) return onevalue(a); } else if (is_numbers(a)) { Header h = numhdr(a); if (!is_bignum_header(h)) return aerror1("bad arg for lsd", a); while ((top = bignum_digits(a)[r]) == 0) r++; r = 31*r; } else return aerror1("bad arg for lsd", a); if (top < 0) return aerror1("negative arg for lsd", a); /* -ve arg */ /* top is non-zero here */ if ((top & 0xffffu) == 0) r += 16, top >>= 16; if ((top & 0xff) == 0) r += 8, top >>= 8; return onevalue(fixnum_of_int(r + lsd_table[top & 0xff])); } Lisp_Object Linorm(Lisp_Object nil, Lisp_Object a, Lisp_Object k) /* * This is a piece of magic especially designed to speed up the * REDUCE big-float code. It adjusts the integer a until it has * just k bits, and returns a correction to the associated exponent. * It combines aspects of msd, lsd, ash and a rounding operation. */ { int32 top, bottom, kk, bits; int32 rtop = 0, rbottom = 0; CSLbool was_fixnum = NO, was_negative = NO, round_up; if (is_fixnum(k) && (int32)k >= 0) kk = int_of_fixnum(k); else return aerror1("bad args for inorm", k); if (is_fixnum(a)) { top = int_of_fixnum(a); if (top == 0) return aerror1("zero arg for inorm", a); bottom = top; was_fixnum = YES; } else if (is_numbers(a)) { Header h = numhdr(a); if (!is_bignum_header(h)) return aerror1("bad arg for inorm", a); rtop = (length_of_header(h)-CELL)/4 - 1; top = bignum_digits(a)[rtop]; was_negative = (top < 0); rtop = 31*rtop; while ((bottom = bignum_digits(a)[rbottom]) == 0) rbottom++; rbottom = 31*rbottom; } else return aerror1("bad arg for inorm", a); if (top < 0) top = ~top; /* Now top is guaranteed positive */ if (top >= 0x10000) rtop += 16, top >>= 16; if (top >= 0x100) rtop += 8, top >>= 8; rtop = rtop + msd_table[top]; if ((bottom & 0xffffu) == 0) rbottom += 16, bottom >>= 16; if ((bottom & 0xff) == 0) rbottom += 8, bottom >>= 8; rbottom = rbottom + lsd_table[bottom & 0xff]; /* * The next line adjusts for the odd case where the input number is * minus an exact power of 2, in which case finding its most significant bit * involved just a little correction. */ round_up = was_negative; if (rtop == rbottom) rtop++; bits = rtop - rbottom; /* bits used in the number */ if (bits <= kk) kk = rbottom; /* no rounding wanted */ else if (was_fixnum) { int bit; /* * If the input was a fixnum and I need to decrease its precision * I will do it in-line here, mainly so that the bignum code that comes * later will not have to worry so much about the possibility of having * any fixnums around. */ kk = rtop - kk; bit = ((int32)1) << (kk - 1); top = int_of_fixnum(a); if (top < 0) { top = -top; /* * It is almost the case that for negative values I should round if the * bit I want to test is a zero (rather than a 1), but this is not true when * the bit involved is the least significant set bit in the word. So to * keep it simple I negate, test, adjust and negate back when working with * single precision numbers. I also do the shifting right on the positive * value to avoid problems with the bits that get shifted off, and with * computers where right shifts are logical rather than arithmetic. */ if ((top & bit) != 0) top += bit; top = top >> kk; top = -top; } else { if ((top & bit) != 0) top += bit; top = top >> kk; } /* * All the shifts I do here move only zero bits off the bottom of the * word, and so there are no issues about +ve vs -ve numbers to bother me. */ while ((top & 0xf) == 0) { top = top >> 4; #ifdef SIGNED_SHIFTS_ARE_LOGICAL if (top & 0x08000000) top |= ~0x0fffffff; #endif kk += 4; } while ((top & 0x1) == 0) { top = top >> 1; #ifdef SIGNED_SHIFTS_ARE_LOGICAL if (top & 0x40000000) top |= ~0x7fffffff; #endif kk += 1; } a = cons(fixnum_of_int(top), fixnum_of_int(kk)); errexit(); return onevalue(a); } else { int32 wk, bk; /* * Here my input was a bignum and I have established that I not only need * to shift it right but that I will need to lose some non-zero digits from * the right hand end. To cope with this I need to decide whether it will * round up or down, and then perform the appropriate shifts, including a * post-normalisation to ensure that the mantissa of the number as returned * is odd. */ kk = rtop - kk; if (rbottom == kk-1) round_up = YES; else { int32 wk1 = (kk-1) / 31, bk1 = (kk-1) % 31; int32 bit = ((int32)1) << bk1; round_up = ((bit & bignum_digits(a)[wk1]) != 0); if (was_negative) round_up = !round_up; } /* * Now I need to find out how much I will need to shift AFTER rounding * and truncation to leave me with a properly normalised value. */ wk = kk / 31, bk = kk % 31; /* * If I have a positive value that is not being rounded up I want to skip * over 0 bits until I find a 1. Similarly for a negative value that is * being rounded up. */ if (was_negative == round_up) { for (;;) { int32 bit = ((int32)1) << bk; if ((bignum_digits(a)[wk] & bit) != 0) break; kk++; bk++; if (bk == 31) bk = 0, wk++; } } else /* * A positive value that is being rounded up or a negative one that is not * should cause me to skip over 1 bits until I find a 0. The 0 I find * will be promoted into a 1 achieve the rounding I need. */ { for (;;) { int32 bit = ((int32)1) << bk; if ((bignum_digits(a)[wk] & bit) == 0) break; kk++; bk++; if (bk == 31) bk = 0, wk++; } } } if (kk != 0) { a = ash(a, fixnum_of_int(-kk)); errexit(); /* * All the adjustment I now need to allow for right-shifting negative * numbers and rounding off - at all reduces to just forcing the bottom bit * of the result I compute here to be a 1! */ if (is_fixnum(a)) a |= 0x10; else bignum_digits(a)[0] |= 1; } a = cons(a, fixnum_of_int(kk)); errexit(); return onevalue(a); } #ifdef COMMON /* * Implemented as a special form for Standard Lisp. Must be a regular * function in Common Lisp. */ static Lisp_Object MS_CDECL Lplus(Lisp_Object nil, int nargs, ...) /* * This adds up a whole bunch of numbers together. * (+ a1 a2 a3 a4 a5) is computed as * (+ a1 (+ a2 (* a3 (+ a4 a5)))) */ { va_list a; int i; Lisp_Object r; if (nargs == 0) return fixnum_of_int(0); va_start(a, nargs); push_args(a, nargs); /* * The actual args have been passed a C args - I can not afford to * risk garbage collection until they have all been moved somewhere safe, * and here that safe place is the Lisp stack. I have to delay checking for * overflow on same until all args have been pushed. */ stackcheck0(nargs); pop(r); nil = C_nil; for (i = 1; i<nargs; i++) { Lisp_Object w; pop(w); if (is_fixnum(r) && is_fixnum(w)) { int32 c = int_of_fixnum(r) + int_of_fixnum(w); int32 w1 = c & fix_mask; if (w1 == 0 || w1 == fix_mask) { r = fixnum_of_int(c); continue; } } r = plus2(r, w); errexitn(nargs-i); } return onevalue(r); } static Lisp_Object MS_CDECL Ldifference(Lisp_Object nil, int nargs, ...) { va_list a; Lisp_Object r; int i; if (nargs == 0) return onevalue(fixnum_of_int(0)); va_start(a, nargs); push_args(a, nargs); stackcheck0(nargs); nil = C_nil; if (nargs == 1) { pop(r); r = negate(r); errexit(); return onevalue(r); } r = stack[1-nargs]; /* * (- a1 a2 a3 a4) is computed as * (((a1 - a4) - a3) - a2) which does not seem too bad here. */ for (i=1; i<nargs; i++) { Lisp_Object w; pop(w); r = difference2(r, w); errexitn(nargs-i); } popv(1); return onevalue(r); } static Lisp_Object MS_CDECL Ltimes(Lisp_Object nil, int nargs, ...) /* * This multiplies a whole bunch of numbers together. */ { va_list a; int i; Lisp_Object r; if (nargs == 0) return fixnum_of_int(1); va_start(a, nargs); push_args(a, nargs); stackcheck0(nargs); pop(r); nil = C_nil; for (i=1; i<nargs; i++) { Lisp_Object w; pop(w); r = times2(r, w); errexitn(nargs-i); } return onevalue(r); } Lisp_Object MS_CDECL Lquotient_n(Lisp_Object nil, int nargs, ...) { va_list a; Lisp_Object r; int i; if (nargs == 0) return onevalue(fixnum_of_int(1)); va_start(a, nargs); push_args(a, nargs); stackcheck0(nargs); if (nargs == 1) { pop(r); r = CLquot2(fixnum_of_int(1), r); errexit(); return onevalue(r); } r = stack[1-nargs]; for (i=1; i<nargs; i++) { Lisp_Object w; pop(w); r = CLquot2(r, w); errexitn(nargs-i); } popv(1); return onevalue(r); } Lisp_Object Lquotient(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { a = CLquot2(a, b); errexit(); return onevalue(a); } static Lisp_Object LSLquotient(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { a = quot2(a, b); errexit(); return onevalue(a); } Lisp_Object Lquotient_1(Lisp_Object nil, Lisp_Object b) { b = CLquot2(fixnum_of_int(1), b); errexit(); return onevalue(b); } #else /* COMMON */ Lisp_Object Lquotient(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { a = quot2(a, b); errexit(); return onevalue(a); } #endif /* COMMON */ Lisp_Object Ldivide(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { Lisp_Object q, r; stackcheck2(0, a, b); push2(a, b); q = quot2(a, b); pop2(b, a); errexit(); push(q); r = Cremainder(a, b); pop(q); errexit(); q = cons(q, r); errexit(); return onevalue(q); } Lisp_Object Lrem(Lisp_Object nil, Lisp_Object p, Lisp_Object q) { p = Cremainder(p, q); errexit(); return onevalue(p); } Lisp_Object Lmod(Lisp_Object nil, Lisp_Object p, Lisp_Object q) { p = modulus(p, q); errexit(); return onevalue(p); } Lisp_Object Lplus2(Lisp_Object nil, Lisp_Object p, Lisp_Object q) { if (is_fixnum(p) && is_fixnum(q)) { int32 c = int_of_fixnum(p) + int_of_fixnum(q); int32 w = c & fix_mask; if (w == 0 || w == fix_mask) return onevalue(fixnum_of_int(c)); } p = plus2(p, q); errexit(); return onevalue(p); } Lisp_Object Ltimes2(Lisp_Object nil, Lisp_Object p, Lisp_Object q) { p = times2(p, q); errexit(); return onevalue(p); } Lisp_Object Ldifference2(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { a = difference2(a, b); errexit(); return onevalue(a); } Lisp_Object Lminus(Lisp_Object nil, Lisp_Object a) { a = negate(a); errexit(); return onevalue(a); } typedef Lisp_Object boolopfn(Lisp_Object, Lisp_Object); static struct bfz { boolopfn *fn; Lisp_Object base; } boolop_array[] = { {0, 0}, {logand2, fixnum_of_int(-1)}, {0, 0}, {0, 0}, {0, 0}, {0, 0}, {logxor2, fixnum_of_int(0)}, {logior2, fixnum_of_int(0)}, {0, 0}, {logeqv2, fixnum_of_int(-1)}, {0, 0}, {0, 0}, {0, 0}, {0, 0}, {0, 0}, {0, 0} }; static Lisp_Object MS_CDECL Lboolfn(Lisp_Object env, int nargs, ...) { va_list a; Lisp_Object nil = C_nil, r; int i; int32 what = int_of_fixnum(env); if (nargs == 0) return onevalue(boolop_array[what].base); va_start(a, nargs); push_args(a, nargs); stackcheck0(nargs); pop(r); for (i=1; i<nargs; i++) { Lisp_Object w; pop(w); r = (*boolop_array[what].fn)(r, w); errexitn(nargs-i); } return onevalue(r); } Lisp_Object Lzerop(Lisp_Object nil, Lisp_Object a) { CSLbool fg; fg = zerop(a); errexit(); return onevalue(Lispify_predicate(fg)); } Lisp_Object Lonep(Lisp_Object nil, Lisp_Object a) { CSLbool fg; fg = onep(a); errexit(); return onevalue(Lispify_predicate(fg)); } Lisp_Object Levenp(Lisp_Object nil, Lisp_Object a) { switch ((int)a & TAG_BITS) { case TAG_FIXNUM: return onevalue(((int32)a & 0x10) == 0 ? lisp_true : nil); case TAG_NUMBERS: if (is_bignum(a)) return onevalue((bignum_digits(a)[0] & 1) == 0 ? lisp_true : nil); /* else drop through */ default: return aerror1("bad arg for evenp", a); } } Lisp_Object Loddp(Lisp_Object nil, Lisp_Object a) { switch ((int)a & TAG_BITS) { case TAG_FIXNUM: return onevalue(((int32)a & 0x10) != 0 ? lisp_true : nil); case TAG_NUMBERS: if (is_bignum(a)) return onevalue((bignum_digits(a)[0] & 1) != 0 ? lisp_true : nil); /* else drop through */ default: return aerror1("oddp", a); } } Lisp_Object Lminusp(Lisp_Object nil, Lisp_Object a) { /* * For CSL I demand (minusp <non-number>) = nil. Note that this ensures * that minusp will not fail... so nil wil be intact on the way out. */ return onevalue(is_number(a) && minusp(a) ? lisp_true : nil); } Lisp_Object Lplusp(Lisp_Object nil, Lisp_Object a) { return onevalue(is_number(a) && plusp(a) ? lisp_true : nil); } /* * The next few functions take an arbitrary number of args in Common * Lisp mode but just 2 args in CSL. */ #ifdef COMMON Lisp_Object MS_CDECL Leqn_n(Lisp_Object nil, int nargs, ...) { va_list a; int i; Lisp_Object r; if (nargs < 2) return onevalue(lisp_true); if (nargs > ARG_CUT_OFF) return aerror("too many args for ="); va_start(a, nargs); push_args(a, nargs); stackcheck0(nargs); r = stack[1-nargs]; for (i = 1; i<nargs; i++) { Lisp_Object s = stack[1+i-nargs]; CSLbool w = numeq2(r, s); nil = C_nil; if (exception_pending()) { popv(nargs); return nil; } if (!w) { popv(nargs); return onevalue(nil); } r = s; } popv(nargs); return onevalue(lisp_true); } Lisp_Object Leqn(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSLbool w = numeq2(a, b); errexit(); return onevalue(w ? lisp_true : nil); } Lisp_Object Leqn_1(Lisp_Object nil, Lisp_Object a) { CSL_IGNORE(nil); CSL_IGNORE(a); return onevalue(lisp_true); } Lisp_Object MS_CDECL Llessp_n(Lisp_Object nil, int nargs, ...) { va_list a; int i; Lisp_Object r; if (nargs < 2) return onevalue(lisp_true); if (nargs > ARG_CUT_OFF) return aerror("too many args for <"); va_start(a, nargs); push_args(a, nargs); stackcheck0(nargs); r = stack[1-nargs]; for (i = 1; i<nargs; i++) { Lisp_Object s = stack[1+i-nargs]; CSLbool w = lessp2(r, s); nil = C_nil; if (exception_pending()) { popv(nargs); return nil; } if (!w) { popv(nargs); return onevalue(nil); } r = s; } popv(nargs); return onevalue(lisp_true); } Lisp_Object Llessp(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSLbool w = lessp2(a, b); errexit(); return onevalue(w ? lisp_true : nil); } Lisp_Object Llessp_1(Lisp_Object nil, Lisp_Object a) { CSL_IGNORE(nil); CSL_IGNORE(a); return onevalue(lisp_true); } Lisp_Object MS_CDECL Lgreaterp_n(Lisp_Object nil, int nargs, ...) { va_list a; int i; Lisp_Object r; if (nargs < 2) return onevalue(lisp_true); if (nargs > ARG_CUT_OFF) return aerror("too many args for >"); va_start(a, nargs); push_args(a, nargs); stackcheck0(nargs); r = stack[1-nargs]; for (i = 1; i<nargs; i++) { Lisp_Object s = stack[1+i-nargs]; CSLbool w = lessp2(s, r); nil = C_nil; if (exception_pending()) { popv(nargs); return nil; } if (!w) { popv(nargs); return onevalue(nil); } r = s; } popv(nargs); return onevalue(lisp_true); } Lisp_Object Lgreaterp(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSLbool w = lessp2(b, a); errexit(); return onevalue(w ? lisp_true : nil); } Lisp_Object Lgreaterp_1(Lisp_Object nil, Lisp_Object a) { CSL_IGNORE(nil); CSL_IGNORE(a); return onevalue(lisp_true); } static Lisp_Object MS_CDECL Lneqn(Lisp_Object nil, int nargs, ...) /* * /= is supposed to check that NO pair of args match. */ { int i, j; Lisp_Object *r; va_list a; if (nargs < 2) return onevalue(lisp_true); r = (Lisp_Object *)&work_1; if (nargs > ARG_CUT_OFF) return aerror("too many args for /="); va_start(a, nargs); for (i=0; i<nargs; i++) r[i] = va_arg(a, Lisp_Object); va_end(a); /* * This bit is OK provided numeq2 does not mess with work_1, ... * and I think that unless funny tracing or errors occur that should * be OK. */ for (i = 1; i<nargs; i++) { Lisp_Object n1 = r[i]; for (j=0; j<i; j++) { Lisp_Object n2 = r[j]; CSLbool w = numeq2(n1, n2); nil = C_nil; if (exception_pending()) return nil; if (w) return onevalue(nil); } } return onevalue(lisp_true); } Lisp_Object Lneq_2(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSLbool w = numeq2(a, b); errexit(); return onevalue(w ? nil : lisp_true); } Lisp_Object Lneq_1(Lisp_Object nil, Lisp_Object a) { CSL_IGNORE(nil); CSL_IGNORE(a); return onevalue(lisp_true); } Lisp_Object MS_CDECL Lgeq_n(Lisp_Object nil, int nargs, ...) { va_list a; int i; Lisp_Object r; if (nargs < 2) return onevalue(lisp_true); if (nargs > ARG_CUT_OFF) return aerror("too many args for >="); va_start(a, nargs); push_args(a, nargs); stackcheck0(nargs); r = stack[1-nargs]; for (i = 1; i<nargs; i++) { Lisp_Object s = stack[1+i-nargs]; CSLbool w = lesseq2(s, r); nil = C_nil; if (exception_pending()) { popv(nargs); return nil; } if (!w) { popv(nargs); return onevalue(nil); } r = s; } popv(nargs); return onevalue(lisp_true); } Lisp_Object Lgeq(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSLbool w = lesseq2(b, a); errexit(); return onevalue(w ? lisp_true : nil); } Lisp_Object Lgeq_1(Lisp_Object nil, Lisp_Object a) { CSL_IGNORE(nil); CSL_IGNORE(a); return onevalue(lisp_true); } Lisp_Object MS_CDECL Lleq_n(Lisp_Object nil, int nargs, ...) { va_list a; int i; Lisp_Object r; if (nargs < 2) return onevalue(lisp_true); if (nargs > ARG_CUT_OFF) return aerror("too many args for <="); va_start(a, nargs); push_args(a, nargs); stackcheck0(nargs); r = stack[1-nargs]; for (i = 1; i<nargs; i++) { Lisp_Object s = stack[1+i-nargs]; CSLbool fg = lesseq2(r, s); nil = C_nil; if (exception_pending()) { popv(nargs); return nil; } if (!fg) { popv(nargs); return onevalue(nil); } r = s; } popv(nargs); return onevalue(lisp_true); } Lisp_Object Lleq(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSLbool w = lesseq2(a, b); errexit(); return onevalue(w ? lisp_true : nil); } Lisp_Object Lleq_1(Lisp_Object nil, Lisp_Object a) { CSL_IGNORE(nil); CSL_IGNORE(a); return onevalue(lisp_true); } #else /* COMMON */ Lisp_Object Leqn(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSLbool r; r = numeq2(a, b); errexit(); return onevalue(Lispify_predicate(r)); } Lisp_Object Llessp(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSLbool r; /* * I have strongish expectations that fixnum arithmetic is so imporant that * it is worth lifting the fixnum comparison up here. */ if (is_fixnum(a) && is_fixnum(b)) return onevalue(Lispify_predicate((int32)a<(int32)b)); r = lessp2(a, b); errexit(); return onevalue(Lispify_predicate(r)); } Lisp_Object Lgreaterp(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSLbool r; if (is_fixnum(a) && is_fixnum(b)) return onevalue(Lispify_predicate((int32)a>(int32)b)); r = lessp2(b, a); errexit(); return onevalue(Lispify_predicate(r)); } Lisp_Object Lgeq(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSLbool r; if (is_fixnum(a) && is_fixnum(b)) return onevalue(Lispify_predicate((int32)a>=(int32)b)); r = lessp2(a, b); errexit(); return onevalue(Lispify_predicate(!r)); } Lisp_Object Lleq(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSLbool r; if (is_fixnum(a) && is_fixnum(b)) return onevalue(Lispify_predicate((int32)a<=(int32)b)); r = lessp2(b, a); errexit(); return onevalue(Lispify_predicate(!r)); } #endif /* COMMON */ Lisp_Object Lmax2(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSLbool w; CSL_IGNORE(nil); push2(a, b); w = lessp2(a, b); pop2(b, a); errexit(); if (w) return onevalue(b); else return onevalue(a); } Lisp_Object Lmin2(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { CSLbool w; CSL_IGNORE(nil); push2(a, b); w = lessp2(b, a); pop2(b, a); errexit(); if (w) return onevalue(b); else return onevalue(a); } Lisp_Object MS_CDECL Lmax(Lisp_Object nil, int nargs, ...) { va_list a; int i; Lisp_Object r; if (nargs < 1) return aerror("max"); if (nargs > ARG_CUT_OFF) return aerror("too many args for max"); va_start(a, nargs); push_args(a, nargs); stackcheck0(nargs); r = stack[1-nargs]; for (i = 1; i<nargs; i++) { Lisp_Object s = stack[1+i-nargs]; CSLbool fg; push2(r, s); fg = lessp2(r, s); pop2(s, r); nil = C_nil; if (exception_pending()) { popv(nargs); return nil; } if (fg) r = s; } popv(nargs); return onevalue(r); } Lisp_Object MS_CDECL Lmin(Lisp_Object nil, int nargs, ...) { va_list a; int i; Lisp_Object r; if (nargs < 1) return aerror("min"); if (nargs > ARG_CUT_OFF) return aerror("too many args for min"); va_start(a, nargs); push_args(a, nargs); stackcheck0(nargs); r = stack[1-nargs]; for (i = 1; i<nargs; i++) { Lisp_Object s = stack[1+i-nargs]; CSLbool fg; push2(r, s); fg = lessp2(s, r); pop2(s, r); nil = C_nil; if (exception_pending()) { popv(nargs); return nil; } if (fg) r = s; } popv(nargs); return onevalue(r); } Lisp_Object Lrational(Lisp_Object nil, Lisp_Object a) { a = rational(a); errexit(); return onevalue(a); } #ifdef COMMON static Lisp_Object Lmanexp(Lisp_Object nil, Lisp_Object a) { int x; double f; if (! is_float(a)) aerror1("arg is not a floating-point number", a); f = float_of_number(a); f = frexp(f, &x); errexit(); return onevalue(cons(make_boxfloat(f,TYPE_DOUBLE_FLOAT), fixnum_of_int(x))); } static Lisp_Object Lrationalize(Lisp_Object nil, Lisp_Object a) { a = rationalize(a); errexit(); return onevalue(a); } #endif /* * The following random number generator is taken from the Norcroft * C library, but is included here so that random sequences will be * identical across all implementations of CSL, and because I have bad * and pessimistic expectations about the quality of random number * generators built into typical C libraries. That is not to say that * I ought not to be somewhat cynical about the code I have implemented * here! But it is tolerably fast and less dreadful than those old * 32-bit linear congruential mistakes. */ static unsigned32 random_number_seed[55]; static int random_j = 23, random_k = 54; static CSLbool randomization_request = NO; /* * If the user specifies a random number seed of zero I will try to * start things in as unpredictable a state as I reasonably can. To * achieve this I will update a block of unpredictable data at a * number of points during a CSL run, garnering incremental amounts * of fairly low grade "randomness" from timing information and the * memory addresses that get allocated to CSL. Because it will take * a while for such information to build up I arrange that specifying * a random seed of zero does not do anything at once (and in particular * the implicit call of this nature when CSL starts doe snot do much), * but the unpredictable mess I accumulate is inspected the first time * any user actually asks for a random value. Since user keyboard input * contributes to the clutter it could be that a cautious user will ask the * user to type in a long string of gibberish before asking for any * random numbers, and the gibberish typed will then in fact form part * of the seed that will be used. On Windows I can hook in and make * mouse activity etc contribute to the seed too. */ static void randomize(void) { int i; random_j = 23; random_k = 54; for (i=20; i<48; i+=4) { MD5_Init(); MD5_Update(unpredictable, sizeof(unpredictable)); MD5_Final((unsigned char *)&random_number_seed[i]); inject_randomness((int)time(NULL)); } /* * Note that I do not initialise the whole array of seed values here. * Leaving something over can count as part of the unpredictability! But I * do try to put in mess through the parts of the seed that will be used * first so that any obvious patterns will get clobbered. */ random_number_seed[0] |= 1; randomization_request = NO; } unsigned32 Crand(void) { /* * See Knuth vol 2 section 3.2.2 for a discussion of this random * number generator. */ unsigned32 temp; if (randomization_request) randomize(); temp = (random_number_seed[random_k] += random_number_seed[random_j]); if (--random_j < 0) random_j = 54, --random_k; else if (--random_k < 0) random_k = 54; return temp; } void Csrand(unsigned32 seed, unsigned32 seed2) { /* * This allows you to put 64 bits of seed into the random sequence, * but it is very improbable that you have any good source of randomness * that good to start with! The input seeds are scrambled using md5 * and then rather crudely widened to fill the whole array of seed data. * If the seed is specified as (0,0) then I will initialise things using * information from the time of day and the clock. This is NOT very * good, especially since I only use portable C-library ways of reading * the time. But it will at least not repeat for any single user and * since the clock information is then scrambled via md5 it will APPEAR * fairly unpredictable. */ int i; random_j = 23; random_k = 54; i = 0; if (seed == 0 && seed2 == 0) { randomization_request = YES; return; } randomization_request = NO; random_number_seed[0] = seed; random_number_seed[1] = 0x12345678; random_number_seed[2] = 0xa7086dee; random_number_seed[3] = seed2; /* * Next I will scramble the seed data that I have been given using md5 * and place the resulting 128 bits of digested stuff in the start of * the seed vector. */ MD5_Init(); MD5_Update((unsigned char *)random_number_seed, 4*sizeof(random_number_seed[0])); MD5_Final((unsigned char *)&random_number_seed[0]); /* * The remainder of the vector gets filled using a simple linear * congruential scheme. */ i = 4; seed = random_number_seed[0]; while (i<55) { seed = 69069*seed + 1725307361; /* computed modulo 2^32 */ random_number_seed[i++] = seed; } /* * I would like to make the least significant bits a little less * regular even to start with, so I xor in from one of the words that * md5 gave me. */ seed = random_number_seed[1]; i = 55-30; while (i<55) { random_number_seed[i++] ^= seed & 1; seed = seed >> 1; } /* * If all the least significant bits were zero to start with they would * always stay that way, so I force one of them to be 1. */ random_number_seed[21] |= 1; } #ifdef COMMON Lisp_Object Lrandom_2(Lisp_Object nil, Lisp_Object a, Lisp_Object bb) { Lisp_Object b; /* * Common Lisp expects an optional second arg to be used for the random * state - at present I do not support that, but it will not be too hard * when I get around to it... */ b = bb; CSL_IGNORE(nil); if (is_fixnum(a)) { int32 v = int_of_fixnum(a), p, q; if (v <= 0) return aerror1("random", a); /* (random 1) always returns zero - a rather silly case! */ else if (v == 1) return onevalue(fixnum_of_int(0)); /* * I generate a value that is an exact multiple of my range (v) and * pick random bitpatterns until I find one less than that. On average * I will have only VERY slightly less than one draw needed, and doing things * this way ought to ensure that my pseudo random numbers are uniformly * distributed provided that the underlying generator is well behaved. */ p = v*(0x7fffffff/v); do q = ((unsigned32)Crand()) >> 1; while (q > p); return onevalue(fixnum_of_int(q % v)); } if (is_numbers(a)) { int32 len, len1, msd; unsigned32 w, w1; Lisp_Object r; if (!is_bignum(a)) return aerror1("random", a); len = bignum_length(a); push(a); r = getvector(TAG_NUMBERS, TYPE_BIGNUM, len); pop(a); errexit(); len1 = (len-CELL)/4-1; restart: len = len1; msd = bignum_digits(a)[len]; if (msd < 0) return aerror("negative arg for random"); /* -ve arg */ if (msd == 0) { bignum_digits(r)[len] = 0; len--; msd = bignum_digits(a)[len]; } for (;;) { w = (0xffffffffU/((unsigned32)msd+1U))*((unsigned32)msd+1U); do w1 = (unsigned32)Crand(); while (w1 >= w); w1 = w1%((unsigned32)msd+1U); bignum_digits(r)[len] = w1; if ((int32)w1 != msd) break; /* * The loop to restart on the next line is when the random value I * have built up word by word ends up being equal to the input number - I * will discard it and start again in that case. */ if (len == 0) goto restart; len--; msd = bignum_digits(a)[len]; } /* * having got some leading digits properly set up I can fill in the rest * as totally independent bit-patterns. */ for (len--;len>=0; len--) bignum_digits(r)[len] = ((unsigned32)Crand())>>1; return onevalue(shrink_bignum(r, len1)); } if (is_bfloat(a)) { Header h = flthdr(a); double d = float_of_number(a), v; /* * The calculation here turns 62 bits of integer data into a floating * point number in the range 0.0 (inclusive) to 1.0 (exclusive). Well, * to be more precise, rounding the value to the machine's floating point * format may round it up to be exactly 1.0, so I discard and cases where * that happens (once in several blue moons...). If I wrote code that * knew exactly how many bits my floating point format had I could avoid * the need for that extra test, but it does not seem very painful to me * and I prefer the more portable code. */ do { v = ((double)(int32)(Crand() & 0x7fffffff)) / TWO_31; v += (double)(int32)(Crand() & 0x7fffffff); v /= TWO_31; v *= d; } while (v == d); a = make_boxfloat(v, type_of_header(h)); errexit(); return onevalue(a); } if (is_sfloat(a)) { Float_union d; float v; d.i = a - TAG_SFLOAT; /* * similar idea to boxfloat case, but only 31 bits randomness used. * SOFTWARE_FLOATING_POINT conversion needed here, maybe */ do { v = (float)(int32)(Crand() & 0x7fffffff)/(float)TWO_31; v = v*d.f; } while (v == d.f); d.f = v; return onevalue((d.i & ~(int32)0xf) + TAG_SFLOAT); } return aerror1("random", a); } #endif Lisp_Object Lrandom(Lisp_Object nil, Lisp_Object a) { CSL_IGNORE(nil); if (is_fixnum(a)) { int32 v = int_of_fixnum(a), p, q; if (v <= 0) return aerror1("random", a); /* (random 1) always returns zero - a rather silly case! */ else if (v == 1) return onevalue(fixnum_of_int(0)); /* * I generate a value that is an exact multiple of my range (v) and * pick random bitpatterns until I find one less than that. On average * I will have only VERY slightly less than one draw needed, and doing things * this way ought to ensure that my pseudo random numbers are uniformly * distributed provided that the underlying generator is well behaved. */ p = v*(0x7fffffff/v); do q = ((unsigned32)Crand()) >> 1; while (q > p); return onevalue(fixnum_of_int(q % v)); } if (is_numbers(a)) { int32 len, len1, msd; unsigned32 w, w1; Lisp_Object r; if (!is_bignum(a)) return aerror1("random", a); len = bignum_length(a); push(a); r = getvector(TAG_NUMBERS, TYPE_BIGNUM, len); pop(a); errexit(); len1 = (len-CELL)/4-1; restart: len = len1; msd = bignum_digits(a)[len]; if (msd < 0) return aerror("negative arg for random"); /* -ve arg */ if (msd == 0) { bignum_digits(r)[len] = 0; len--; msd = bignum_digits(a)[len]; } for (;;) { w = (0xffffffffU/((unsigned32)msd+1U))*((unsigned32)msd+1U); do w1 = (unsigned32)Crand(); while (w1 >= w); w1 = w1%((unsigned32)msd+1U); bignum_digits(r)[len] = w1; if ((int32)w1 != msd) break; /* * The loop to restart on the next line is when the random value I * have built up word by word ends up being equal to the input number - I * will discard it and start again in that case. */ if (len == 0) goto restart; len--; msd = bignum_digits(a)[len]; } /* * having got some leading digits properly set up I can fill in the rest * as totally independent bit-patterns. */ for (len--;len>=0; len--) bignum_digits(r)[len] = ((unsigned32)Crand())>>1; return onevalue(shrink_bignum(r, len1)); } if (is_bfloat(a)) { Header h = flthdr(a); double d = float_of_number(a), v; /* * The calculation here turns 62 bits of integer data into a floating * point number in the range 0.0 (inclusive) to 1.0 (exclusive). Well, * to be more precise, rounding the value to the machine's floating point * format may round it up to be exactly 1.0, so I discard and cases where * that happens (once in several blue moons...). If I wrote code that * knew exactly how many bits my floating point format had I could avoid * the need for that extra test, but it does not seem very painful to me * and I prefer the more portable code. */ do { v = ((double)(int32)(Crand() & 0x7fffffff)) / TWO_31; v += (double)(int32)(Crand() & 0x7fffffff); v /= TWO_31; v *= d; } while (v == d); a = make_boxfloat(v, type_of_header(h)); errexit(); return onevalue(a); } #ifdef COMMON if (is_sfloat(a)) { Float_union d; float v; d.i = a - TAG_SFLOAT; /* * similar idea to boxfloat case, but only 31 bits randomness used. * SOFTWARE_FLOATING_POINT conversion needed here, maybe */ do { v = (float)(int32)(Crand() & 0x7fffffff)/(float)TWO_31; v = v*d.f; } while (v == d.f); d.f = v; return onevalue((d.i & ~(int32)0xf) + TAG_SFLOAT); } #endif return aerror1("random", a); } Lisp_Object MS_CDECL Lnext_random(Lisp_Object nil, int nargs, ...) /* * Returns a random positive fixnum. 27 bits in this Lisp! */ { int32 r; argcheck(nargs, 0, "next-random"); CSL_IGNORE(nil); r = Crand(); return onevalue((Lisp_Object)((r & 0x7ffffff0) + TAG_FIXNUM)); } Lisp_Object Lmake_random_state(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { /* * Nasty temporary hack here to allow me to set the seed for the * random number generator in Standard Lisp mode. I need to re-think * this soon before it feels frozen in! Oops - too late!!! */ CSL_IGNORE(b); if (!is_fixnum(a)) return aerror1("make-random-state", a); Csrand(int_of_fixnum(a), is_fixnum(b) ? int_of_fixnum(b) : 0); return onevalue(nil); } Lisp_Object Lmake_random_state1(Lisp_Object nil, Lisp_Object a) { if (!is_fixnum(a)) return aerror1("make-random-state", a); Csrand(int_of_fixnum(a), 0); return onevalue(nil); } /* * The function md5() can be given a number or a string as an argument, * and it uses the md5 message digest algorithm to reduce it to a * numeric value in the range 0 to 2^128. * Well actually I will also allow an arbitrary expression, which I * will treat as if it has to be printed... */ Lisp_Object Lmd5(Lisp_Object env, Lisp_Object a) { Lisp_Object nil = C_nil; Lisp_Object r; unsigned char md[16]; unsigned32 v0, v1, v2, v3, v4; int32 len, i; CSL_IGNORE(env); if (is_fixnum(a)) { sprintf((char *)md, "%.8lx", (unsigned long)a); MD5_Init(); MD5_Update(md, 8); } else if (is_numbers(a) && is_bignum_header(numhdr(a))) { len = length_of_header(numhdr(a)); MD5_Init(); for (i=CELL; i<len; i+=4) { sprintf((char *)md, "%.8lx", (unsigned long)bignum_digits(a)[(i-CELL)/4]); MD5_Update(md, 8); } } else if (is_vector(a) && type_of_header(vechdr(a)) == TYPE_STRING) { len = length_of_header(vechdr(a)); MD5_Init(); MD5_Update((unsigned char *)(a + CELL - TAG_VECTOR), len-CELL); } else checksum(a); MD5_Final(md); v0 = md[0] + (md[1]<<8) + (md[2]<<16) + (md[3]<<24); v1 = md[4] + (md[5]<<8) + (md[6]<<16) + (md[7]<<24); v2 = md[8] + (md[9]<<8) + (md[10]<<16) + (md[11]<<24); v3 = md[12] + (md[13]<<8) + (md[14]<<16) + (md[15]<<24); v4 = v3 >> 28; v3 = ((v3 << 3) | (v2 >> 29)) & 0x7fffffff; v2 = ((v2 << 2) | (v1 >> 30)) & 0x7fffffff; v1 = ((v1 << 1) | (v0 >> 31)) & 0x7fffffff; v0 &= 0x7fffffff; /* * Note the funny tests. This is because in my representation the * top word of a bignum is a 2s complement signed value and to keep clear * of overflow that means I use an extra digit slightly before one might * imagine it is necessary! */ if (v4 != 0 || (v3 & 0x40000000) != 0) len = CELL+20; else if (v3 != 0 || (v2 & 0x40000000) != 0) len = CELL+16; else if (v2 != 0 || (v1 & 0x40000000) != 0) len = CELL+12; else if (v1 != 0 || (v0 & 0x40000000) != 0) len = CELL+8; else if ((v0 & fix_mask) != 0) len = CELL+4; else return onevalue(fixnum_of_int(v0)); r = getvector(TAG_NUMBERS, TYPE_BIGNUM, len); errexit(); #ifdef ADDRESS_64 switch (len) { case CELL+20: bignum_digits(r)[5] = 0; /* zeros out padding word as necessary */ bignum_digits(r)[4] = v4; case CELL+16: case CELL+12: bignum_digits(r)[3] = v3; bignum_digits(r)[2] = v2; case CELL+8: case CELL+4: bignum_digits(r)[1] = v1; bignum_digits(r)[0] = v0; break; } #else switch (len) { case CELL+20: case CELL+16: bignum_digits(r)[4] = v4; /* zeros out padding word as necessary */ bignum_digits(r)[3] = v3; case CELL+12: case CELL+8: bignum_digits(r)[2] = v2; bignum_digits(r)[1] = v1; case CELL+4: bignum_digits(r)[0] = v0; break; } #endif /* validate_number("MD5", r, r, r); */ return onevalue(r); } /* * md60 is a function that uses MD5 but then returns just about 60 bits * of number not 128. It is for use when the full 128 bits of checksum * would be clumsy overkill. */ Lisp_Object Lmd60(Lisp_Object env, Lisp_Object a) { Lisp_Object nil = C_nil; Lisp_Object r; unsigned char md[16]; unsigned32 v0, v1; int32 len, i; CSL_IGNORE(env); if (is_fixnum(a)) { sprintf((char *)md, "%.8lx", (unsigned long)a); MD5_Init(); MD5_Update(md, 8); } else if (is_numbers(a) && is_bignum_header(numhdr(a))) { len = length_of_header(numhdr(a)); MD5_Init(); for (i=CELL; i<len; i+=4) { sprintf((char *)md, "%.8lx", (unsigned long)bignum_digits(a)[(i-CELL)/4]); MD5_Update(md, 8); } } else if (is_vector(a) && type_of_header(vechdr(a)) == TYPE_STRING) { len = length_of_header(vechdr(a)); MD5_Init(); MD5_Update((unsigned char *)(a + CELL - TAG_VECTOR), len-CELL); } else checksum(a); MD5_Final(md); v0 = md[0] + (md[1]<<8) + (md[2]<<16) + (md[3]<<24); v1 = md[4] + (md[5]<<8) + (md[6]<<16) + (md[7]<<24); v1 = ((v1 << 1) | (v0 >> 31)) & 0x3fffffff; v0 &= 0x7fffffff; if (v1 != 0 || (v0 & 0x40000000) != 0) len = CELL+8; else if ((v0 & fix_mask) != 0) len = CELL+4; else return onevalue(fixnum_of_int(v0)); r = getvector(TAG_NUMBERS, TYPE_BIGNUM, len); errexit(); #ifdef ADDRESS_64 bignum_digits(r)[1] = v1; bignum_digits(r)[0] = v0; #else switch (len) { case CELL+8: bignum_digits(r)[2] = 0; bignum_digits(r)[1] = v1; case CELL+4: bignum_digits(r)[0] = v0; break; } #endif /* validate_number("MD60", r, r, r); */ return onevalue(r); } static Lisp_Object Llogand2(Lisp_Object env, Lisp_Object a1, Lisp_Object a2) { return Lboolfn(env, 2, a1, a2); } static Lisp_Object Llogeqv2(Lisp_Object env, Lisp_Object a1, Lisp_Object a2) { return Lboolfn(env, 2, a1, a2); } static Lisp_Object Llogxor2(Lisp_Object env, Lisp_Object a1, Lisp_Object a2) { return Lboolfn(env, 2, a1, a2); } static Lisp_Object Llogor2(Lisp_Object env, Lisp_Object a1, Lisp_Object a2) { return Lboolfn(env, 2, a1, a2); } static Lisp_Object MS_CDECL Ldemo_mode(Lisp_Object nil, int nargs, ...) { argcheck(nargs, 0, "demo-mode"); #ifdef DEMO_BUILD /* if (qfn1(compiler_symbol) == undefined1) */ { Csrand(demo_key1, demo_key2); return onevalue(lisp_true); } #endif return onevalue(nil); } setup_type const arith06_setup[] = { {"ash", too_few_2, Lash, wrong_no_2}, {"ash1", too_few_2, Lash1, wrong_no_2}, {"divide", too_few_2, Ldivide, wrong_no_2}, {"evenp", Levenp, too_many_1, wrong_no_1}, {"inorm", too_few_2, Linorm, wrong_no_2}, {"logand", Lidentity, Llogand2, Lboolfn}, {"logeqv", Lidentity, Llogeqv2, Lboolfn}, {"lognot", Llognot, too_many_1, wrong_no_1}, {"logxor", Lidentity, Llogxor2, Lboolfn}, {"lsd", Llsd, too_many_1, wrong_no_1}, {"make-random-state", Lmake_random_state1, Lmake_random_state, wrong_no_2}, {"max", Lidentity, Lmax2, Lmax}, {"max2", too_few_2, Lmax2, wrong_no_2}, {"min", Lidentity, Lmin2, Lmin}, {"min2", too_few_2, Lmin2, wrong_no_2}, {"minus", Lminus, too_many_1, wrong_no_1}, {"minusp", Lminusp, too_many_1, wrong_no_1}, {"mod", too_few_2, Lmod, wrong_no_2}, {"msd", Lmsd, too_many_1, wrong_no_1}, {"oddp", Loddp, too_many_1, wrong_no_1}, {"onep", Lonep, too_many_1, wrong_no_1}, {"plus2", too_few_2, Lplus2, wrong_no_2}, {"plusp", Lplusp, too_many_1, wrong_no_1}, {"rational", Lrational, too_many_1, wrong_no_1}, {"times2", too_few_2, Ltimes2, wrong_no_2}, {"zerop", Lzerop, too_many_1, wrong_no_1}, {"md5", Lmd5, too_many_1, wrong_no_1}, {"md60", Lmd60, too_many_1, wrong_no_1}, {"demo-mode", wrong_no_0a, wrong_no_0b, Ldemo_mode}, #ifdef COMMON {"*", Lidentity, Ltimes2, Ltimes}, {"+", Lidentity, Lplus2, Lplus}, {"-", Lminus, Ldifference2, Ldifference}, {"/", Lquotient_1, Lquotient, Lquotient_n}, {"/=", Lneq_1, Lneq_2, Lneqn}, {"1+", Ladd1, too_many_1, wrong_no_1}, {"1-", Lsub1, too_many_1, wrong_no_1}, {"<", Llessp_1, Llessp, Llessp_n}, {"<=", Lleq_1, Lleq, Lleq_n}, {"=", Leqn_1, Leqn, Leqn_n}, {">", Lgreaterp_1, Lgreaterp, Lgreaterp_n}, {">=", Lgeq_1, Lgeq, Lgeq_n}, {"float", Lfloat, Lfloat_2, wrong_no_1}, {"logior", Lidentity, Llogor2, Lboolfn}, {"random", Lrandom, Lrandom_2, wrong_no_1}, {"rationalize", Lrationalize, too_many_1, wrong_no_1}, {"manexp", Lmanexp, too_many_1, wrong_no_1}, {"rem", too_few_2, Lrem, wrong_no_2}, /* * I also provide the old style names to make porting code easier for me */ {"times", Lidentity, Ltimes2, Ltimes}, {"plus", Lidentity, Lplus2, Lplus}, {"times2", too_few_2, Ltimes2, wrong_no_2}, {"plus2", too_few_2, Lplus2, wrong_no_2}, {"minus", Lminus, too_many_1, wrong_no_1}, {"difference", too_few_2, Ldifference2, Ldifference}, /* I leave QUOTIENT as the integer-truncating form, while "/" gives ratios */ {"quotient", too_few_2, LSLquotient, wrong_no_2}, {"remainder", too_few_2, Lrem, wrong_no_2}, {"add1", Ladd1, too_many_1, wrong_no_1}, {"sub1", Lsub1, too_many_1, wrong_no_1}, {"lessp", Llessp_1, Llessp, Llessp_n}, {"leq", Lleq_1, Lleq, Lleq_n}, {"eqn", Leqn_1, Leqn, Leqn_n}, {"greaterp", Lgreaterp_1, Lgreaterp, Lgreaterp_n}, {"geq", Lgeq_1, Lgeq, Lgeq_n}, {"next-random-number", wrong_no_0a, wrong_no_0b, Lnext_random}, {"logor", Lidentity, Llogor2, Lboolfn}, #else {"add1", Ladd1, too_many_1, wrong_no_1}, {"difference", too_few_2, Ldifference2, wrong_no_2}, {"eqn", too_few_2, Leqn, wrong_no_2}, {"float", Lfloat, too_many_1, wrong_no_1}, {"geq", too_few_2, Lgeq, wrong_no_2}, {"greaterp", too_few_2, Lgreaterp, wrong_no_2}, {"leq", too_few_2, Lleq, wrong_no_2}, {"lessp", too_few_2, Llessp, wrong_no_2}, {"logor", Lidentity, Llogor2, Lboolfn}, {"quotient", too_few_2, Lquotient, wrong_no_2}, /* * I used to call these just random and next-random-number, but REDUCE * wants its own versions of those (for cross-Lisp consistency) so I use * alternative names here. */ {"random-number", Lrandom, too_many_1, wrong_no_1}, {"random-fixnum", wrong_no_0a, wrong_no_0b, Lnext_random}, {"remainder", too_few_2, Lrem, wrong_no_2}, {"sub1", Lsub1, too_many_1, wrong_no_1}, #endif {NULL, 0, 0, 0} }; /* end of arith06.c */