From b6fc855410806bcd5b57dee66d0d5a649e3473ed Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Wed, 1 Aug 2001 16:47:19 +0000 Subject: [PATCH] Bit fiddling functions (boolean, logand, logbit, etc) now work with negative bignums. --- src/CHANGELOG | 10 ++ src/c/all_functions.d | 6 + src/c/big.d | 13 +- src/c/num_arith.d | 34 ++--- src/c/num_log.d | 346 +++++++++++++++++++++--------------------- src/c/num_sfun.d | 22 ++- src/h/external.h | 4 +- src/h/lisp_external.h | 8 +- src/lsp/numlib.lsp | 13 +- 9 files changed, 229 insertions(+), 227 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 1003dcc88..c478099e6 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -731,6 +731,16 @@ ECLS 0.3 - Remove use of alloca() when printing circular structures. +ECLS 0.3b +========= + +* Errors fixed: + + - Fixnum product would overflow: (* 65536 32768) => negative number. + + - Bit fiddling operations with negative fixnums now work (i.e. + LOGAND, LOGOR, LOGBITP, etc). + TODO: ===== diff --git a/src/c/all_functions.d b/src/c/all_functions.d index 7fc487a98..a3b9a47d8 100644 --- a/src/c/all_functions.d +++ b/src/c/all_functions.d @@ -484,6 +484,12 @@ const struct function_info all_functions[] = { {"LOGXOR", clLlogxor, cl}, {"LOGAND", clLlogand, cl}, {"LOGEQV", clLlogeqv, cl}, + {"LOGNAND", clLlognand, cl}, + {"LOGNOR", clLlognor, cl}, + {"LOGANDC1", clLlogandc1, cl}, + {"LOGANDC2", clLlogandc1, cl}, + {"LOGORC1", clLlogorc1, cl}, + {"LOGORC2", clLlogorc2, cl}, {"BOOLE", clLboole, cl}, {"LOGBITP", clLlogbitp, cl}, {"ASH", clLash, cl}, diff --git a/src/c/big.d b/src/c/big.d index ebf37a559..39a9c9882 100644 --- a/src/c/big.d +++ b/src/c/big.d @@ -79,10 +79,13 @@ big_register_normalize(cl_object x) if (s == 0) return(MAKE_FIXNUM(0)); y = x->big.big_limbs[0]; - if (s == 1 && y <= MOST_POSITIVE_FIX) - return(MAKE_FIXNUM(y)); - if (s == -1 && y <= MOST_POSITIVE_FIX + 1) - return(MAKE_FIXNUM(-y)); + if (s == 1) { + if (y <= MOST_POSITIVE_FIX) + return(MAKE_FIXNUM(y)); + } else if (s == -1) { + if (y <= -MOST_POSITIVE_FIX) + return(MAKE_FIXNUM(-y)); + } return big_register_copy(x); } @@ -231,7 +234,7 @@ big_normalize(cl_object x) y = x->big.big_limbs[0]; if (s == 1 && y <= MOST_POSITIVE_FIX) return(MAKE_FIXNUM(y)); - if (s == -1 && y <= MOST_POSITIVE_FIX + 1) + if (s == -1 && y <= -MOST_NEGATIVE_FIX) return(MAKE_FIXNUM(-y)); return(x); } diff --git a/src/c/num_arith.d b/src/c/num_arith.d index 9a18c33e2..413d67e9e 100644 --- a/src/c/num_arith.d +++ b/src/c/num_arith.d @@ -28,34 +28,18 @@ @) cl_object -fixnum_times(int i, int j) +fixnum_times(cl_fixnum i, cl_fixnum j) { + cl_object x = big_register0_get(); - int high, sign; - mp_limb_t i0, j0, res[2]; - cl_object z; - - if (i == 0 || j == 0) - return(MAKE_FIXNUM(0)); - i0 = abs(i); - j0 = abs(j); - sign = ((i >= 0 && j >= 0) || (i < 0 && j < 0)) ? 1 : -1; - high = mpn_mul(res, &i0, 1, &j0, 1); - if (high == 0) { - if (sign > 0) { - if (res[0] <= MOST_POSITIVE_FIX) - return(MAKE_FIXNUM(res[0])); - } else { - if (res[0] <= (MOST_POSITIVE_FIX + 1)) - return(MAKE_FIXNUM(-res[0])); - } - z = alloc_object(t_bignum); - mpz_init_set_si(z->big.big_num, sign * res[0]); - } else { - z = bignum2(res[1], res[0]); - z->big.big_size = sign * 2; + mpz_set_si(x->big.big_num, i); + if (j > 0) + mpz_mul_ui(x->big.big_num, x->big.big_num, j); + else { + mpz_mul_ui(x->big.big_num, x->big.big_num, -j); + mpz_neg(x->big.big_num, x->big.big_num); } - return(z); + return big_register_normalize(x); } static cl_object diff --git a/src/c/num_log.d b/src/c/num_log.d index b247336e7..47e3d81f8 100644 --- a/src/c/num_log.d +++ b/src/c/num_log.d @@ -40,10 +40,12 @@ fixnum or bignum ( not normalized ) */ -static cl_object big_log_op(struct bignum *x, cl_object y, int (*op)()); +typedef cl_fixnum (*bit_operator)(cl_fixnum, cl_fixnum); + +static cl_object big_log_op(cl_object x, cl_object y, bit_operator op); static cl_object -log_op(int narg, int (*op)(), va_list ARGS) +log_op(int narg, bit_operator op, va_list ARGS) { enum cl_type t; cl_object x, numi; @@ -63,7 +65,7 @@ log_op(int narg, int (*op)(), va_list ARGS) numi = cl_nextarg(ARGS); t = type_of(numi); if (t == t_bignum) { - x = big_log_op(&bignum1(j)->big, numi, op); + x = big_log_op(bignum1(j), numi, op); i++; goto BIG_OP; } else if (t != t_fixnum) { @@ -75,196 +77,187 @@ log_op(int narg, int (*op)(), va_list ARGS) BIG_OP: for (; i < narg; i++) - x = big_log_op(&x->big, cl_nextarg(ARGS), op); + x = big_log_op(x, cl_nextarg(ARGS), op); return(big_normalize(x)); } + +static cl_object +log_op2(cl_object x, cl_object y, bit_operator op) +{ + switch (type_of(x)) { + case t_fixnum: + if (FIXNUMP(y)) + return MAKE_FIXNUM((*op)(fix(x),fix(y))); + else + x = big_log_op(bignum1(fix(x)), y, op); + break; + case t_bignum: + x = big_log_op(big_copy(x), y, op); + break; + default: + FEtype_error_integer(x); + } + return big_normalize(x); +} + /* big_log_op(x, y, op) performs the logical operation op on bignum x and integer y, and returns the result in x destructively. */ static cl_object -big_log_op(struct bignum *x, cl_object y, int (*op)()) +big_log_op(cl_object x, cl_object y, bit_operator op) { - int i, j; - int y_size, x_size = x->big_size; - mp_limb_t *y_limbs, *x_limbs = x->big_limbs; - int y_sign, x_sign = (big_sign((cl_object)x) < 0); + int flag; + int y_size, x_size; + mp_limb_t word, *x_limbs, *y_limbs; if (FIXNUMP(y)) { - i = fix(y); - x_limbs[x_size-1] = (*op)(x_limbs[x_size-1], i); - y_sign = (i < 0); + cl_object z = big_register1_get(); + mpz_set_si(y->big.big_num, fix(y)); + y = z; } else if (type_of(y) != t_bignum) { - FEtype_error_integer(y); - } else { - y_sign = big_sign((cl_object)y) < 0; - x_size = abs(x->big_size); - y_size = abs(y->big.big_size); - y_limbs = y->big.big_limbs; - - if (y_size > x_size) { - /* First loop finds the size of the result. */ - for (i = y_size - 1; i >= 0; i--) { - j = (i >= x_size) ? 0 : x_limbs[i]; - if ((*op)(j, y_limbs[i]) != 0) - break; - } - x_size = i + 1; - - /* Handle allocation, now that we know exactly how much space is - needed for the result. */ - if (x->big_dim < x_size) { - _mpz_realloc(x->big_num, x_size); - x_limbs = x->big_limbs; - } - } - /* Second loop computes the real result. */ - for (i = 0 ; i < x_size; i++) - x_limbs[i] = (*op)(x_limbs[i], y_limbs[i]); + FEtype_error_integer(y); } - /* - Set the sign according to operation. - */ - x->big_size = (*op)(x_sign, y_sign)? -x_size : x_size; - return((cl_object)x); + if (big_sign(y) > 0) + flag = 0; + else { + cl_object z = big_register2_get(); + mpz_com(z->big.big_num, y->big.big_num); + y = z; + flag = ~0; + } + y_size = y->big.big_size; + y_limbs = y->big.big_limbs; + if (big_sign(x) > 0) + flag = (*op)(0,flag); + else { + flag = (*op)(0,flag); + mpz_com(x->big.big_num, x->big.big_num); + } + x_size = x->big.big_size; + if (y_size > x_size) { + x->big.big_size = x_size = y_size; + mpz_realloc(x->big.big_num, x_size); + } + x_limbs = x->big.big_limbs; + + /* Compute the logical operation */ + for (word = 0; x_size--; ) { + mp_limb_t aux = (*op)(x_limbs[x_size], y_limbs[x_size]); + x_limbs[x_size] = aux; + word |= aux; + } + /* When output is zero, notice that */ + if (word == 0) + x->big.big_size = 0; + /* If result should be a negative number, perform two's complement. */ + if (flag) + mpz_com(x->big.big_num, x->big.big_num); + return x; } -static int -ior_op(int i, int j) +static cl_fixnum +ior_op(cl_fixnum i, cl_fixnum j) { return(i | j); } -static int -xor_op(int i, int j) +static cl_fixnum +xor_op(cl_fixnum i, cl_fixnum j) { return(i ^ j); } -static int -and_op(int i, int j) +static cl_fixnum +and_op(cl_fixnum i, cl_fixnum j) { return(i & j); } -static int -eqv_op(int i, int j) +static cl_fixnum +eqv_op(cl_fixnum i, cl_fixnum j) { return(~(i ^ j)); } -static int -nand_op(int i, int j) +static cl_fixnum +nand_op(cl_fixnum i, cl_fixnum j) { return(~(i & j)); } -static int -nor_op(int i, int j) +static cl_fixnum +nor_op(cl_fixnum i, cl_fixnum j) { return(~(i | j)); } -static int -andc1_op(int i, int j) +static cl_fixnum +andc1_op(cl_fixnum i, cl_fixnum j) { return((~i) & j); } -static int -andc2_op(int i, int j) +static cl_fixnum +andc2_op(cl_fixnum i, cl_fixnum j) { return(i & (~j)); } -static int -orc1_op(int i, int j) +static cl_fixnum +orc1_op(cl_fixnum i, cl_fixnum j) { return((~i) | j); } -static int -orc2_op(int i, int j) +static cl_fixnum +orc2_op(cl_fixnum i, cl_fixnum j) { return(i | (~j)); } -static int -b_clr_op(int i, int j) +static cl_fixnum +b_clr_op(cl_fixnum i, cl_fixnum j) { return(0); } -static int -b_set_op(int i, int j) +static cl_fixnum +b_set_op(cl_fixnum i, cl_fixnum j) { return(-1); } -static int -b_1_op(int i, int j) +static cl_fixnum +b_1_op(cl_fixnum i, cl_fixnum j) { return(i); } -static int -b_2_op(int i, int j) +static cl_fixnum +b_2_op(cl_fixnum i, cl_fixnum j) { return(j); } -static int -b_c1_op(int i, int j) +static cl_fixnum +b_c1_op(cl_fixnum i, cl_fixnum j) { return(~i); } -static int -b_c2_op(int i, int j) +static cl_fixnum +b_c2_op(cl_fixnum i, cl_fixnum j) { return(~j); } -static int -big_bitp(cl_object x, int p) -{ - if (p < 0) - return 0; - else { -#define BITS_PER_LIMB (sizeof(mp_limb_t)*8) - int size = x->big.big_size; - mp_limb_t *limbs = x->big.big_limbs; - int cell = p / BITS_PER_LIMB; - int bit = p % BITS_PER_LIMB; - if (size > 0) - if (cell > size) - return(size < 0); - else - return (limbs[cell] >> bit) & 1; - else { - mp_size_t zero_bound; - size = -size; - /* Locate the least significant non-zero limb. */ - for (zero_bound = 0; limbs[zero_bound] == 0; zero_bound++) - ; - if (cell > size) - return 1; - else if (cell < zero_bound) - return 0; - else if (cell == zero_bound) - return (-limbs[cell] >> bit) & 1; - else /* cell > zero_bound */ - return (~limbs[cell] >> bit) & 1; - } - } -} - @(defun lognot (x) @ return @logxor(1,x,MAKE_FIXNUM(-1)); @) -static int +static cl_fixnum count_bits(cl_object x) { cl_fixnum count; @@ -278,11 +271,14 @@ count_bits(cl_object x) break; } case t_bignum: - if (big_sign(x) < 0) { - @lognot(1,x); - VALUES(0) = x; + if (big_sign(x) >= 0) + count = mpz_popcount(x->big.big_num); + else { + cl_object z = big_register0_get(); + mpz_com(z->big.big_num, x->big.big_num); + count = mpz_popcount(x->big.big_num); + big_register_free(z); } - count = mpz_popcount(x->big.big_num); break; default: FEtype_error_integer(x); @@ -294,39 +290,23 @@ count_bits(cl_object x) Left shift if w > 0, right shift if w < 0. */ cl_object -integer_shift(cl_object x, int w) +integer_shift(cl_object x, cl_fixnum w) { cl_object y; - int cell, bits, i; - - if (w == 0) return(x); - cell = w / 32; - bits = w % 32; - if (FIXNUMP(x)) { - i = fix(x); - if (i == 0) return(x); - if (cell == 0) { - if (w < 0) { - if (i >= 0) - return(MAKE_FIXNUM(i >> -w)); - else - return(MAKE_FIXNUM(~((~i) >> -w))); - } - if (i > 0) { - if (((~MOST_POSITIVE_FIX >> w) & i) == 0) - return(MAKE_FIXNUM(i << w)); - } else { - if (((MOST_NEGATIVE_FIX >> w) & ~i) == 0) - return(MAKE_FIXNUM(i << w)); - } - } - x = bignum1(i); - } + + if (w == 0) + return(x); y = big_register0_get(); if (w < 0) { - mpz_div_2exp(y->big.big_num, x->big.big_num, -w); + if (FIXNUMP(x)) + return MAKE_FIXNUM(fix(x) >> -w); + mpz_div_2exp(y->big.big_num, x->big.big_num, -w); } else { - mpz_mul_2exp(y->big.big_num, x->big.big_num, w); + if (FIXNUMP(x)) { + mpz_set_si(y->big.big_num, fix(x)); + x = y; + } + mpz_mul_2exp(y->big.big_num, x->big.big_num, w); } return(big_register_normalize(y)); } @@ -346,9 +326,7 @@ int_bit_length(int i) @ if (narg == 0) @(return MAKE_FIXNUM(0)) - /* INV: log_op() checks types */ - if (narg == 1) - @(return cl_nextarg(nums)) + /* INV: log_op() checks types and outputs first argument as default. */ @(return log_op(narg, ior_op, nums)) @) @@ -356,9 +334,7 @@ int_bit_length(int i) @ if (narg == 0) @(return MAKE_FIXNUM(0)) - /* INV: log_op() checks types */ - if (narg == 1) - @(return cl_nextarg(nums)) + /* INV: log_op() checks types and outputs first argument as default. */ @(return log_op(narg, xor_op, nums)) @) @@ -366,9 +342,7 @@ int_bit_length(int i) @ if (narg == 0) @(return MAKE_FIXNUM(-1)) - /* INV: log_op() checks types */ - if (narg == 1) - @(return cl_nextarg(nums)) + /* INV: log_op() checks types and outputs first argument as default. */ @(return log_op(narg, and_op, nums)) @) @@ -376,17 +350,43 @@ int_bit_length(int i) @ if (narg == 0) @(return MAKE_FIXNUM(-1)) - /* INV: log_op() checks types */ - if (narg == 1) - @(return cl_nextarg(nums)) + /* INV: log_op() checks types and outputs first argument as default. */ @(return log_op(narg, eqv_op, nums)) @) -@(defun boole (o &rest nums) +@(defun lognand (x y) +@ + @(return log_op2(x, y, nand_op)) +@) + +@(defun lognor (x y) +@ + @(return log_op2(x, y, nor_op)) +@) + +@(defun logandc1 (x y) +@ + @(return log_op2(x, y, andc1_op)) +@) + +@(defun logandc2 (x y) +@ + @(return log_op2(x, y, andc2_op)) +@) + +@(defun logorc1 (x y) +@ + @(return log_op2(x, y, orc1_op)) +@) + +@(defun logorc2 (x y) +@ + @(return log_op2(x, y, orc2_op)) +@) + +@(defun boole (o x y) int (*op)(); @ - /* FIXME! Is this check ok? */ - check_arg(3); /* INV: log_op() checks types */ switch(fixint(o)) { case BOOLCLR: op = b_clr_op; break; @@ -409,23 +409,29 @@ int_bit_length(int i) FEerror("~S is an invalid logical operator.", 1, o); } - @(return log_op(2, op, nums)) + @(return log_op2(x, y, op)) @) @(defun logbitp (p x) bool i; + int n; @ - assert_type_non_negative_integer(p); assert_type_integer(x); - if (FIXNUMP(p)) + if (FIXNUMP(p)) { + cl_fixnum n = fixnnint(p); + if (n < 0) + FEtype_error_index(p); if (FIXNUMP(x)) - i = ((fix(x) >> fix(p)) & 1); + i = ((fix(x) >> n) & 1); else - i = big_bitp(x, fix(p)); - else if (FIXNUMP(x)) - i = (fix(x) < 0); - else - i = (big_sign(x) < 0); + i = mpz_tstbit(x->big.big_num, n); + } else { + assert_type_non_negative_integer(p); + if (FIXNUMP(x)) + i = (fix(x) < 0); + else + i = (big_sign(x) < 0); + } @(return (i ? Ct : Cnil)) @) @@ -444,12 +450,12 @@ int_bit_length(int i) according to sign of integer. */ if (FIXNUMP(x)) - if (fix(x) > 0) - sign_x = 1; - else if (fix(x) == 0) + if (FIXNUM_MINUSP(x)) + sign_x = -1; + else if (x == MAKE_FIXNUM(0)) sign_x = 0; else - sign_x = -1; + sign_x = 1; else sign_x = big_sign(x); if (big_sign(y) < 0) diff --git a/src/c/num_sfun.d b/src/c/num_sfun.d index b2b806723..05e204828 100644 --- a/src/c/num_sfun.d +++ b/src/c/num_sfun.d @@ -94,10 +94,8 @@ number_expt(cl_object x, cl_object y) enum type tx, ty; cl_object z; - tx = type_of(x); - ty = type_of(y); - if (ty == t_fixnum && fix(y) == 0) - switch (tx) { + if (y == MAKE_FIXNUM(0)) + switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: return(MAKE_FIXNUM(1)); @@ -115,6 +113,7 @@ number_expt(cl_object x, cl_object y) default: FEtype_error_number(x); } + ty = type_of(y); if (number_zerop(x)) { if (!number_plusp(ty==t_complex?y->complex.real:y)) FEerror("Cannot raise zero to the power ~S.", 1, y); @@ -128,15 +127,14 @@ number_expt(cl_object x, cl_object y) return(z); } z = MAKE_FIXNUM(1); - while (number_plusp(y)) - if (number_evenp(y)) { - x = number_times(x, x); - y = integer_divide(y, MAKE_FIXNUM(2)); - } else { + do { + /* INV: integer_divide outputs an integer */ + if (!number_evenp(y)) z = number_times(z, x); - y = number_minus(y, MAKE_FIXNUM(1)); - } - return(z); + x = number_times(x, x); + y = integer_divide(y, MAKE_FIXNUM(2)); + } while (number_plusp(y)); + return z; } z = number_nlog(x); z = number_times(z, y); diff --git a/src/h/external.h b/src/h/external.h index a6e012d9d..e9b0299f3 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -493,7 +493,7 @@ extern void init_multival(void); /* num_arith.c */ -extern cl_object cl_fixnumimes(int i, int j); +extern cl_object fixnum_times(cl_fixnum i, cl_fixnum j); extern cl_object number_times(cl_object x, cl_object y); extern cl_object number_to_complex(cl_object x); extern cl_object number_plus(cl_object x, cl_object y); @@ -546,7 +546,7 @@ extern void init_num_comp(void); /* num_log.c */ -extern cl_object integer_shift(cl_object x, int w); +extern cl_object integer_shift(cl_object x, cl_fixnum w); extern int int_bit_length(int i); extern void init_num_log(void); diff --git a/src/h/lisp_external.h b/src/h/lisp_external.h index 6e69fe996..3f549a35b 100644 --- a/src/h/lisp_external.h +++ b/src/h/lisp_external.h @@ -553,7 +553,13 @@ extern cl_object clLlogior _ARGS((int narg, ...)); extern cl_object clLlogxor _ARGS((int narg, ...)); extern cl_object clLlogand _ARGS((int narg, ...)); extern cl_object clLlogeqv _ARGS((int narg, ...)); -extern cl_object clLboole _ARGS((int narg, cl_object o, ...)); +extern cl_object clLlognand _ARGS((int narg, cl_object x, cl_object y)); +extern cl_object clLlognor _ARGS((int narg, cl_object x, cl_object y)); +extern cl_object clLlogandc1 _ARGS((int narg, cl_object x, cl_object y)); +extern cl_object clLlogandc2 _ARGS((int narg, cl_object x, cl_object y)); +extern cl_object clLlogorc1 _ARGS((int narg, cl_object x, cl_object y)); +extern cl_object clLlogorc2 _ARGS((int narg, cl_object x, cl_object y)); +extern cl_object clLboole _ARGS((int narg, cl_object o, cl_object x, cl_object y)); extern cl_object clLlogbitp _ARGS((int narg, cl_object p, cl_object x)); extern cl_object clLash _ARGS((int narg, cl_object x, cl_object y)); extern cl_object clLlogcount _ARGS((int narg, cl_object x)); diff --git a/src/lsp/numlib.lsp b/src/lsp/numlib.lsp index 892a20872..9f5bf61eb 100644 --- a/src/lsp/numlib.lsp +++ b/src/lsp/numlib.lsp @@ -15,9 +15,7 @@ (c-declaim (si::c-export-fname isqrt abs phase signum cis asin acos asinh acosh atanh rational ffloor fceiling ftruncate fround - lognand lognor logandc1 logandc2 logorc1 logorc2 - lognot logtest - byte byte-size byte-position + logtest byte byte-size byte-position ldb ldb-test mask-field dpb deposit-field)) (defconstant imag-one #C(0.0 1.0)) @@ -159,15 +157,6 @@ (multiple-value-bind (i r) (round (float x) (float y)) (values (float i r) r))) - -(defun lognand (x y) (boole boole-nand x y)) -(defun lognor (x y) (boole boole-nor x y)) -(defun logandc1 (x y) (boole boole-andc1 x y)) -(defun logandc2 (x y) (boole boole-andc2 x y)) -(defun logorc1 (x y) (boole boole-orc1 x y)) -(defun logorc2 (x y) (boole boole-orc2 x y)) - -;(defun lognot (x) (logxor -1 x)) (defun logtest (x y) (not (zerop (logand x y))))