mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-02 07:30:55 -08:00
Bit fiddling functions (boolean, logand, logbit, etc) now work with negative bignums.
This commit is contained in:
jjgarcia
parent
4b7fe789bb
commit
b6fc855410
9 changed files with 229 additions and 227 deletions
|
|
@ -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:
|
||||
=====
|
||||
|
||||
|
|
|
|||
|
|
@ -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},
|
||||
|
|
|
|||
13
src/c/big.d
13
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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
346
src/c/num_log.d
346
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)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue