num_log.d 17.6 KB
Newer Older
1
/* -*- mode: c; c-basic-offset: 8 -*- */
jjgarcia's avatar
jjgarcia committed
2 3 4 5 6 7 8 9
/*
    num_log.c  -- Logical operations on numbers.
*/
/*
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
    Copyright (c) 1990, Giuseppe Attardi.
    Copyright (c) 2001, Juan Jose Garcia Ripoll.

10
    ECL is free software; you can redistribute it and/or
jjgarcia's avatar
jjgarcia committed
11 12 13 14 15 16 17
    modify it under the terms of the GNU Library General Public
    License as published by the Free Software Foundation; either
    version 2 of the License, or (at your option) any later version.

    See file '../Copyright' for full details.
*/

18
#include <ecl/ecl.h>
jjgarcia's avatar
jjgarcia committed
19
#include <stdlib.h>
20
#include <ecl/internal.h>
jjgarcia's avatar
jjgarcia committed
21 22

/*
23 24
 * BIT OPERATIONS FOR FIXNUMS
 */
jjgarcia's avatar
jjgarcia committed
25

26 27
static cl_fixnum
ior_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
28
{
29
	return(i | j);
jjgarcia's avatar
jjgarcia committed
30
}
31

32 33
static void
mpz_ior_op(cl_object i, cl_object j)
34
{
35
#ifdef WITH_GMP
36
	mpz_ior(i->big.big_num, i->big.big_num, j->big.big_num);
37 38 39
#else  /* WITH_GMP */
        i->big.big_num |= j->big.big_num;
#endif /* WITH_GMP */
jjgarcia's avatar
jjgarcia committed
40 41
}

42
static cl_fixnum
43
xor_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
44
{
45
	return(i ^ j);
jjgarcia's avatar
jjgarcia committed
46 47
}

48 49
static void
mpz_xor_op(cl_object i, cl_object j)
jjgarcia's avatar
jjgarcia committed
50
{
51
#ifdef WITH_GMP
52
	mpz_xor(i->big.big_num, i->big.big_num, j->big.big_num);
53 54 55
#else  /* WITH_GMP */
        i->big.big_num ^= j->big.big_num;
#endif /* WITH_GMP */
jjgarcia's avatar
jjgarcia committed
56 57
}

58 59
static cl_fixnum
and_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
60 61 62 63
{
	return(i & j);
}

64 65 66
static void
mpz_and_op(cl_object i, cl_object j)
{
67
#ifdef WITH_GMP
68
	mpz_and(i->big.big_num, i->big.big_num, j->big.big_num);
69 70 71
#else  /* WITH_GMP */
        i->big.big_num &= j->big.big_num;
#endif /* WITH_GMP */
72 73
}

74 75
static cl_fixnum
eqv_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
76 77 78 79
{
	return(~(i ^ j));
}

80 81 82
static void
mpz_eqv_op(cl_object i, cl_object j)
{
83
#ifdef WITH_GMP
84 85
	mpz_xor(i->big.big_num, i->big.big_num, j->big.big_num);
	mpz_com(i->big.big_num, i->big.big_num);
86 87 88
#else  /* WITH_GMP */
        i->big.big_num = ~(i->big.big_num ^ j->big.big_num);
#endif /* WITH_GMP */
89 90
}

91 92
static cl_fixnum
nand_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
93 94 95 96
{
	return(~(i & j));
}

97 98 99
static void
mpz_nand_op(cl_object i, cl_object j)
{
100
#ifdef WITH_GMP
101 102
	mpz_and(i->big.big_num, i->big.big_num, j->big.big_num);
	mpz_com(i->big.big_num, i->big.big_num);
103 104 105
#else  /* WITH_GMP */
        i->big.big_num = ~(i->big.big_num & j->big.big_num);
#endif /* WITH_GMP */
106 107
}

108 109
static cl_fixnum
nor_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
110 111 112 113
{
	return(~(i | j));
}

114 115 116
static void
mpz_nor_op(cl_object i, cl_object j)
{
117
#ifdef WITH_GMP
118 119
	mpz_ior(i->big.big_num, i->big.big_num, j->big.big_num);
	mpz_com(i->big.big_num, i->big.big_num);
120 121 122
#else  /* WITH_GMP */
        i->big.big_num = ~(i->big.big_num | j->big.big_num);
#endif /* WITH_GMP */
123 124
}

125 126
static cl_fixnum
andc1_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
127 128 129 130
{
	return((~i) & j);
}

131 132 133
static void
mpz_andc1_op(cl_object i, cl_object j)
{
134
#ifdef WITH_GMP
135 136
	mpz_com(i->big.big_num, i->big.big_num);
	mpz_and(i->big.big_num, i->big.big_num, j->big.big_num);
137 138 139
#else  /* WITH_GMP */
        i->big.big_num = (~i->big.big_num) & (big_num_t)j;
#endif /* WITH_GMP */
140 141
}

142 143
static cl_fixnum
andc2_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
144 145 146 147
{
	return(i & (~j));
}

148 149 150 151 152
static void mpz_orc1_op(cl_object, cl_object);

static void
mpz_andc2_op(cl_object i, cl_object j)
{
153
#ifdef WITH_GMP
154 155 156
	/* (i & ~j) = ~((~i) | j) */
	mpz_orc1_op(i, j);
	mpz_com(i->big.big_num, i->big.big_num);
157 158 159
#else  /* WITH_GMP */
        i->big.big_num = i->big.big_num & (~j->big.big_num);
#endif /* WITH_GMP */
160 161
}

162 163
static cl_fixnum
orc1_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
164 165 166 167
{
	return((~i) | j);
}

168 169 170
static void
mpz_orc1_op(cl_object i, cl_object j)
{
171
#ifdef WITH_GMP
172 173
	mpz_com(i->big.big_num, i->big.big_num);
	mpz_ior(i->big.big_num, i->big.big_num, j->big.big_num);
174 175 176
#else  /* WITH_GMP */
        i->big.big_num = (~i->big.big_num) | j->big.big_num;
#endif /* WITH_GMP */
177 178
}

179 180
static cl_fixnum
orc2_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
181 182 183 184
{
	return(i | (~j));
}

185 186 187
static void
mpz_orc2_op(cl_object i, cl_object j)
{
188
#ifdef WITH_GMP
189 190 191
	/* (i | ~j) = ~((~i) & j) */
	mpz_andc1_op(i, j);
	mpz_com(i->big.big_num, i->big.big_num);
192 193 194
#else  /* WITH_GMP */
        i->big.big_num = i->big.big_num | (~j->big.big_num);
#endif /* WITH_GMP */
195 196
}

197 198
static cl_fixnum
b_clr_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
199 200 201 202
{
	return(0);
}

203 204 205
static void
mpz_b_clr_op(cl_object i, cl_object j)
{
206
#ifdef WITH_GMP
207
	mpz_set_si(i->big.big_num, 0);
208 209 210
#else  /* WITH_GMP */
        i->big.big_num = 0ll;
#endif /* WITH_GMP */
211 212
}

213 214
static cl_fixnum
b_set_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
215 216 217 218
{
	return(-1);
}

219 220 221
static void
mpz_b_set_op(cl_object i, cl_object j)
{
222
#ifdef WITH_GMP
223
	mpz_set_si(i->big.big_num, -1);
224 225 226
#else  /* WITH_GMP */
        i->big.big_num = -1ll;
#endif /* WITH_GMP */
227 228
}

229 230
static cl_fixnum
b_1_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
231 232 233 234
{
	return(i);
}

235 236 237 238 239
static void
mpz_b_1_op(cl_object i, cl_object j)
{
}

240 241
static cl_fixnum
b_2_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
242 243 244 245
{
	return(j);
}

246 247 248
static void
mpz_b_2_op(cl_object i, cl_object j)
{
249
#ifdef WITH_GMP
250
	mpz_set(i->big.big_num, j->big.big_num);
251 252 253
#else  /* WITH_GMP */
        i->big.big_num = j->big.big_num;
#endif /* WITH_GMP */
254 255
}

256 257
static cl_fixnum
b_c1_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
258 259 260 261
{
	return(~i);
}

262 263 264
static void
mpz_b_c1_op(cl_object i, cl_object j)
{
265
#ifdef WITH_GMP
266
	mpz_com(i->big.big_num, i->big.big_num);
267 268 269
#else  /* WITH_GMP */
        i->big.big_num = ~i->big.big_num;
#endif /* WITH_GMP */
270 271
}

272 273
static cl_fixnum
b_c2_op(cl_fixnum i, cl_fixnum j)
jjgarcia's avatar
jjgarcia committed
274 275 276 277
{
	return(~j);
}

278 279 280
static void
mpz_b_c2_op(cl_object i, cl_object j)
{
281
#ifdef WITH_GMP
282
	mpz_com(i->big.big_num, j->big.big_num);
283 284 285
#else  /* WITH_GMP */
        i->big.big_num = ~j->big.big_num;
#endif /* WITH_GMP */
286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328
}

typedef cl_fixnum (*bit_operator)(cl_fixnum, cl_fixnum);
typedef void (*bignum_bit_operator)(cl_object, cl_object);

static bit_operator fixnum_operations[16] = {
	b_clr_op,
	and_op,
	andc2_op,
	b_1_op,
	andc1_op,
	b_2_op,
	xor_op,
	ior_op,
	nor_op,
	eqv_op,
	b_c2_op,
	orc2_op,
	b_c1_op,
	orc1_op,
	nand_op,
	b_set_op};

static bignum_bit_operator bignum_operations[16] = {
	mpz_b_clr_op,
	mpz_and_op,
	mpz_andc2_op,
	mpz_b_1_op,
	mpz_andc1_op,
	mpz_b_2_op,
	mpz_xor_op,
	mpz_ior_op,
	mpz_nor_op,
	mpz_eqv_op,
	mpz_b_c2_op,
	mpz_orc2_op,
	mpz_b_c1_op,
	mpz_orc1_op,
	mpz_nand_op,
	mpz_b_set_op};


static cl_object
329
log_op(cl_narg narg, int op, cl_va_list ARGS)
330
{
331 332 333 334 335 336 337 338
	cl_object x, y;
	/* FIXME! This can be optimized */
	x = cl_va_arg(ARGS);
	if (narg-- == 1) {
		assert_type_integer(x);
	} else {
		do {
			y = cl_va_arg(ARGS);
339
			x = ecl_boole(op, x, y);
340 341 342
		} while (--narg);
	}
	return x;
343 344
}

345 346
cl_object
ecl_boole(int op, cl_object x, cl_object y)
347 348 349 350 351
{
	switch (type_of(x)) {
	case t_fixnum:
		switch (type_of(y)) {
		case t_fixnum: {
352 353
			cl_fixnum z = fixnum_operations[op](fix(x), fix(y));
			return MAKE_FIXNUM(z);
354 355
		}
		case t_bignum: {
356
                        cl_object x_copy = _ecl_big_register0();
357
                        _ecl_big_set_fixnum(x_copy, fix(x));
358
			bignum_operations[op](x_copy, y);
359
                        return _ecl_big_register_normalize(x_copy);
360 361
		}
		default:
362
                        FEwrong_type_nth_arg(@[boole], 2, y, @[integer]);
363 364 365
		}
		break;
	case t_bignum: {
366
                cl_object x_copy = _ecl_big_register0();
367
                _ecl_big_set(x_copy, x);
368 369
		switch (type_of(y)) {
		case t_fixnum: {
370
			cl_object z = _ecl_big_register1();
371
                        _ecl_big_set_fixnum(z,fix(y));
372
			bignum_operations[op](x_copy, z);
373
			_ecl_big_register_free(z);
374 375 376
			break;
		}
		case t_bignum:
377
			bignum_operations[op](x_copy, y);
378 379
			break;
		default:
380
                        FEwrong_type_nth_arg(@[boole], 2, y, @[integer]);
381
		}
382
                return _ecl_big_register_normalize(x_copy);
383 384
	}
	default:
385
                FEwrong_type_nth_arg(@[boole], 1, x, @[integer]);
386
	}
387
	return x;
388 389
}

390 391 392
cl_object
cl_lognot(cl_object x)
{
393
	return @logxor(2,x,MAKE_FIXNUM(-1));
394
}
jjgarcia's avatar
jjgarcia committed
395

396
static cl_fixnum
jjgarcia's avatar
jjgarcia committed
397 398 399 400 401 402 403 404 405
count_bits(cl_object x)
{
	cl_fixnum count;

	switch (type_of(x)) {
	case t_fixnum: {
		cl_fixnum i = fix(x);
		cl_fixnum j = (i < 0) ? ~i : i;
		for (count=0 ; j ; j >>= 1)
406
			if (j & 1) count++;
jjgarcia's avatar
jjgarcia committed
407 408 409
		break;
	}
	case t_bignum:
410
#ifdef WITH_GMP
411
		if (_ecl_big_sign(x) >= 0)
412 413
			count = mpz_popcount(x->big.big_num);
		else {
414
			cl_object z = _ecl_big_register0();
415
			mpz_com(z->big.big_num, x->big.big_num);
416
			count = mpz_popcount(z->big.big_num);
417
			_ecl_big_register_free(z);
jjgarcia's avatar
jjgarcia committed
418
		}
419 420 421 422 423 424 425 426 427
#else  /* WITH_GMP */
                {
                     big_num_t i = x->big.big_num;
                     if ( i<0 ) 
                          i = ~i;
                     for ( count=0 ; i ; i >>= 1 )
                          if ( i&1 ) count++;
                }
#endif /* WITH_GMP */
jjgarcia's avatar
jjgarcia committed
428 429
		break;
	default:
430
                FEwrong_type_only_arg(@[logcount], x, @[integer]);
jjgarcia's avatar
jjgarcia committed
431 432 433 434 435 436 437 438
	}
	return count;
}

/*
   Left shift if w > 0, right shift if w < 0.
 */
cl_object
439
ecl_ash(cl_object x, cl_fixnum w)
jjgarcia's avatar
jjgarcia committed
440 441
{
	cl_object y;
442 443 444

	if (w == 0)
		return(x);
445
	y = _ecl_big_register0();
jjgarcia's avatar
jjgarcia committed
446
	if (w < 0) {
447
		cl_index bits = -w;
448
		if (FIXNUMP(x)) {
449 450 451 452 453 454 455
			/* The result of shifting a number further than the number
			 * of digits it has is unpredictable in C. For instance, GCC
			 * on intel masks out all bits of "bits" beyond the 5 and
			 * it may happen that a shift of 37 becomes a shift of 5.
			 * Furthermore, in general, shifting negative numbers leads
			 * to implementation-specific results :-/
			 */
456
			cl_fixnum y = fix(x);
457 458 459 460 461
			if (bits >= FIXNUM_BITS) {
				y = (y < 0)? -1 : 0;
			} else {
				y >>= bits;
			}
462 463
			return MAKE_FIXNUM(y);
		}
464
#ifdef WITH_GMP
465
		mpz_div_2exp(y->big.big_num, x->big.big_num, bits);
466 467 468
#else  /* WITH_GMP */
                y->big.big_num = x->big.big_num >> bits;
#endif /* WITH_GMP */
jjgarcia's avatar
jjgarcia committed
469
	} else {
470
#ifdef WITH_GMP
471
		if (FIXNUMP(x)) {
472
			_ecl_big_set_fixnum(y, fix(x));
473 474
			x = y;
		}
475
		mpz_mul_2exp(y->big.big_num, x->big.big_num, (unsigned long)w);
476 477 478 479
#else  /* WITH_GMP */
                y->big.big_num = FIXNUMP(x) ? fix(x) : x->big.big_num;
                y->big.big_num <<= w;
#endif /* WITH_GMP */
jjgarcia's avatar
jjgarcia committed
480
	}
481
	return _ecl_big_register_normalize(y);
jjgarcia's avatar
jjgarcia committed
482 483
}

484 485
int
ecl_fixnum_bit_length(cl_fixnum i)
jjgarcia's avatar
jjgarcia committed
486
{
487 488 489 490 491 492
	int count;
	if (i < 0)
		i = ~i;
	for (count = 0; i && (count < FIXNUM_BITS); i >>= 1, count++)
		;
	return count;
jjgarcia's avatar
jjgarcia committed
493 494 495 496 497 498
}

@(defun logior (&rest nums)
@
	if (narg == 0)
		@(return MAKE_FIXNUM(0))
499
	/* INV: log_op() checks types and outputs first argument as default. */
500
	@(return log_op(narg, ECL_BOOLIOR, nums))
jjgarcia's avatar
jjgarcia committed
501 502 503 504 505 506
@)

@(defun logxor (&rest nums)
@
	if (narg == 0)
		@(return MAKE_FIXNUM(0))
507
	/* INV: log_op() checks types and outputs first argument as default. */
508
	@(return log_op(narg, ECL_BOOLXOR, nums))
jjgarcia's avatar
jjgarcia committed
509 510 511 512 513 514
@)

@(defun logand (&rest nums)
@
	if (narg == 0)
		@(return MAKE_FIXNUM(-1))
515
	/* INV: log_op() checks types and outputs first argument as default. */
516
	@(return log_op(narg, ECL_BOOLAND, nums))
jjgarcia's avatar
jjgarcia committed
517 518 519 520 521 522
@)

@(defun logeqv (&rest nums)
@
	if (narg == 0)
		@(return MAKE_FIXNUM(-1))
523
	/* INV: log_op() checks types and outputs first argument as default. */
524
	@(return log_op(narg, ECL_BOOLEQV, nums))
jjgarcia's avatar
jjgarcia committed
525 526
@)

527 528 529
cl_object
cl_lognand(cl_object x, cl_object y)
{
530
	@(return ecl_boole(ECL_BOOLNAND, x, y))
531
}
532

533 534 535
cl_object
cl_lognor(cl_object x, cl_object y)
{
536
	@(return ecl_boole(ECL_BOOLNOR, x, y))
537
}
538

539 540 541
cl_object
cl_logandc1(cl_object x, cl_object y)
{
542
	@(return ecl_boole(ECL_BOOLANDC1, x, y))
543
}
544

545 546 547
cl_object
cl_logandc2(cl_object x, cl_object y)
{
548
	@(return ecl_boole(ECL_BOOLANDC2, x, y))
549
}
550

551 552 553
cl_object
cl_logorc1(cl_object x, cl_object y)
{
554
	@(return ecl_boole(ECL_BOOLORC1, x, y))
555
}
556

557 558 559
cl_object
cl_logorc2(cl_object x, cl_object y)
{
560
	@(return ecl_boole(ECL_BOOLORC2, x, y))
561 562 563 564 565 566 567
}

static int
coerce_to_logical_operator(cl_object o)
{
	cl_fixnum op;
	op = fixint(o);
568
	if (op < 0 || op > ECL_BOOLSET)
569 570
		FEerror("~S is an invalid logical operator.", 1, o);
	return op;
571
}
572

573 574 575
cl_object
cl_boole(cl_object o, cl_object x, cl_object y)
{
576
	/* INV: log_op2() checks types */
577
	@(return ecl_boole(coerce_to_logical_operator(o), x, y))
578
}
jjgarcia's avatar
jjgarcia committed
579

580 581 582
cl_object
cl_logbitp(cl_object p, cl_object x)
{
583
	bool i;
584

jjgarcia's avatar
jjgarcia committed
585
	assert_type_integer(x);
586
	if (FIXNUMP(p)) {
587
		cl_index n = fixnnint(p);
588 589 590 591 592 593 594 595
		if (FIXNUMP(x)) {
			cl_fixnum y = fix(x);
			if (n >= FIXNUM_BITS) {
				i = (y < 0);
			} else {
				i = ((y >> n) & 1);
			}
		} else {
596
#ifdef WITH_GMP
597
			i = mpz_tstbit(x->big.big_num, n);
598 599 600 601 602 603 604
#else  /* WITH_GMP */
                        if ( n >= 8*sizeof(big_num_t) ) {
                                i = (x->big.big_num < 0);
                        } else {
                                i = (x->big.big_num >> n) & 1;
                        }
#endif /* WITH_GMP */
605
		}
606 607 608 609 610
	} else {
		assert_type_non_negative_integer(p);
		if (FIXNUMP(x))
			i = (fix(x) < 0);
		else
611
			i = (_ecl_big_sign(x) < 0);
612
	}
jjgarcia's avatar
jjgarcia committed
613
	@(return (i ? Ct : Cnil))
614
}
jjgarcia's avatar
jjgarcia committed
615

616 617 618
cl_object
cl_ash(cl_object x, cl_object y)
{
jjgarcia's avatar
jjgarcia committed
619 620
	cl_object r;
	int sign_x;
621

jjgarcia's avatar
jjgarcia committed
622 623 624
        assert_type_integer(x);
	assert_type_integer(y);
	if (FIXNUMP(y))
625
	  r = ecl_ash(x, fix(y));
jjgarcia's avatar
jjgarcia committed
626 627 628 629 630 631 632
	else {
	  /*
	    bit position represented by bignum is probably
	    out of our address space. So, result is returned
	    according to sign of integer.
	    */
	  if (FIXNUMP(x))
633 634 635
	    if (FIXNUM_MINUSP(x))
	      sign_x = -1;
	    else if (x == MAKE_FIXNUM(0))
jjgarcia's avatar
jjgarcia committed
636 637
	      sign_x = 0;
	    else
638
	      sign_x = 1;
jjgarcia's avatar
jjgarcia committed
639
	  else
640 641
	    sign_x = _ecl_big_sign(x);
	  if (_ecl_big_sign(y) < 0)
jjgarcia's avatar
jjgarcia committed
642 643 644 645 646 647 648 649 650 651
	    if (sign_x < 0)
	      r = MAKE_FIXNUM(-1);
	    else
	      r = MAKE_FIXNUM(0);
	  else if (sign_x == 0)
	    r = x;
	  else
	    FEerror("Insufficient memory.", 0);
	}
	@(return r)
652
}
jjgarcia's avatar
jjgarcia committed
653

654 655 656
cl_object
cl_logcount(cl_object x)
{
jjgarcia's avatar
jjgarcia committed
657
	@(return MAKE_FIXNUM(count_bits(x)))
658
}
jjgarcia's avatar
jjgarcia committed
659

660 661
cl_index
ecl_integer_length(cl_object x)
662
{
663 664
	int count;
	cl_fixnum i;
665

jjgarcia's avatar
jjgarcia committed
666 667 668
	switch (type_of(x)) {
	case t_fixnum:
		i = fix(x);
669
		count = ecl_fixnum_bit_length(i);
jjgarcia's avatar
jjgarcia committed
670
		break;
671
	case t_bignum:
672
		if (_ecl_big_sign(x) < 0)
673
			x = cl_lognot(x);
674
#ifdef WITH_GMP
675
		count = mpz_sizeinbase(x->big.big_num, 2);
676 677 678 679 680 681 682
#else  /* WITH_GMP */
                for ( i=(8*sizeof(big_num_t))-1 ; i>0 ; i-- )
                        if ( (x->big.big_num >> i) & 1 ) {
                                count = i;
                                break;
                        }
#endif /* WITH_GMP */
jjgarcia's avatar
jjgarcia committed
683 684
		break;
	default:
685
                FEwrong_type_only_arg(@[integer-length], x, @[integer]);
jjgarcia's avatar
jjgarcia committed
686
	}
687 688 689 690 691 692 693
	return count;
}

cl_object
cl_integer_length(cl_object x)
{
	@(return MAKE_FIXNUM(ecl_integer_length(x)))
694
}
jjgarcia's avatar
jjgarcia committed
695

696 697 698
cl_object
si_bit_array_op(cl_object o, cl_object x, cl_object y, cl_object r)
{
jjgarcia's avatar
jjgarcia committed
699 700
	cl_fixnum i, j, n, d;
	cl_object r0;
701
	bit_operator op;
jjgarcia's avatar
jjgarcia committed
702 703 704 705
	bool replace = FALSE;
	int xi, yi, ri;
	byte *xp, *yp, *rp;
	int xo, yo, ro;
706

jjgarcia's avatar
jjgarcia committed
707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739
	if (type_of(x) == t_bitvector) {
		d = x->vector.dim;
		xp = x->vector.self.bit;
		xo = x->vector.offset;
		if (type_of(y) != t_bitvector)
			goto ERROR;
		if (d != y->vector.dim)
			goto ERROR;
		yp = y->vector.self.bit;
		yo = y->vector.offset;
		if (r == Ct)
			r = x;
		if (r != Cnil) {
			if (type_of(r) != t_bitvector)
				goto ERROR;
			if (r->vector.dim != d)
				goto ERROR;
			i = (r->vector.self.bit - xp)*8 + (r->vector.offset - xo);
			if ((i > 0 && i < d) || (i < 0 && -i < d)) {
				r0 = r;
				r = Cnil;
				replace = TRUE;
				goto L1;
			}
			i = (r->vector.self.bit - yp)*8 + (r->vector.offset - yo);
			if ((i > 0 && i < d) || (i < 0 && -i < d)) {
				r0 = r;
				r = Cnil;
				replace = TRUE;
			}
		}
	L1:
		if (Null(r)) {
740
			r = ecl_alloc_simple_vector(d, aet_bit);
jjgarcia's avatar
jjgarcia committed
741 742 743 744
		}
	} else {
		if (type_of(x) != t_array)
			goto ERROR;
745
		if ((cl_elttype)x->array.elttype != aet_bit)
jjgarcia's avatar
jjgarcia committed
746 747 748 749 750 751
			goto ERROR;
		d = x->array.dim;
		xp = x->vector.self.bit;
		xo = x->vector.offset;
		if (type_of(y) != t_array)
			goto ERROR;
752
		if ((cl_elttype)y->array.elttype != aet_bit)
jjgarcia's avatar
jjgarcia committed
753 754 755 756 757 758 759 760 761 762 763 764 765
			goto ERROR;
		if (x->array.rank != y->array.rank)
			goto ERROR;
		yp = y->vector.self.bit;
		yo = y->vector.offset;
		for (i = 0;  i < x->array.rank;  i++)
			if (x->array.dims[i] != y->array.dims[i])
				goto ERROR;
		if (r == Ct)
			r = x;
		if (r != Cnil) {
			if (type_of(r) != t_array)
				goto ERROR;
766
			if ((cl_elttype)r->array.elttype != aet_bit)
jjgarcia's avatar
jjgarcia committed
767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788
				goto ERROR;
			if (r->array.rank != x->array.rank)
				goto ERROR;
			for (i = 0;  i < x->array.rank;  i++)
				if (r->array.dims[i] != x->array.dims[i])
					goto ERROR;
			i = (r->vector.self.bit - xp)*8 + (r->vector.offset - xo);
			if ((i > 0 && i < d) || (i < 0 && -i < d)) {
				r0 = r;
				r = Cnil;
				replace = TRUE;
				goto L2;
			} 
			i = (r->vector.self.bit - yp)*8 + (r->vector.offset - yo);
			if ((i > 0 && i < d) || (i < 0 && -i < d)) {
				r0 = r;
				r = Cnil;
				replace = TRUE;
			}
		}
	L2:
		if (Null(r)) {
789
		  r = ecl_alloc_object(t_array);
jjgarcia's avatar
jjgarcia committed
790 791
		  r->array.self.t = NULL;
		  r->array.displaced = Cnil;
jjgarcia's avatar
jjgarcia committed
792 793 794
		  r->array.rank = x->array.rank;
		  r->array.dims = x->array.dims;
		  r->array.elttype = aet_bit;
jjgarcia's avatar
jjgarcia committed
795
		  r->array.dim = x->array.dim;
796
		  r->array.flags = 0; /* no fill pointer, not adjustable */
797
		  ecl_array_allocself(r);
jjgarcia's avatar
jjgarcia committed
798 799 800 801
		}
	}
	rp = r->vector.self.bit;
	ro = r->vector.offset;
802
	op = fixnum_operations[coerce_to_logical_operator(o)];
jjgarcia's avatar
jjgarcia committed
803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855

#define	set_high(place, nbits, value) \
	(place)=((place)&~(-0400>>(nbits)))|((value)&(-0400>>(nbits)))

#define	set_low(place, nbits, value) \
	(place)=((place)&(-0400>>(8-(nbits))))|((value)&~(-0400>>(8-(nbits))))

#define	extract_byte(integer, pointer, index, offset) \
	(integer) = (pointer)[(index)+1] & 0377; \
	(integer) = ((pointer)[index]<<(offset))|((integer)>>(8-(offset)))

#define	store_byte(pointer, index, offset, value) \
	set_low((pointer)[index], 8-(offset), (value)>>(offset)); \
	set_high((pointer)[(index)+1], offset, (value)<<(8-(offset)))

	if (xo == 0 && yo == 0 && ro == 0) {
		for (n = d/8, i = 0;  i < n;  i++)
			rp[i] = (*op)(xp[i], yp[i]);
		if ((j = d%8) > 0)
			set_high(rp[n], j, (*op)(xp[n], yp[n]));
		if (!replace)
			@(return r)
	} else {
		for (n = d/8, i = 0;  i <= n;  i++) {
			extract_byte(xi, xp, i, xo);
			extract_byte(yi, yp, i, yo);
			if (i == n) {
				if ((j = d%8) == 0)
					break;
				extract_byte(ri, rp, n, ro);
				set_high(ri, j, (*op)(xi, yi));
			} else
				ri = (*op)(xi, yi);
			store_byte(rp, i, ro, ri);
		}
		if (!replace)
			@(return r)
	}
	rp = r0->vector.self.bit;
	ro = r0->vector.offset;
	for (n = d/8, i = 0;  i <= n;  i++) {
		if (i == n) {
			if ((j = d%8) == 0)
				break;
			extract_byte(ri, rp, n, ro);
			set_high(ri, j, r->vector.self.bit[n]);
		} else
			ri = r->vector.self.bit[i];
		store_byte(rp, i, ro, ri);
	}
	@(return r0)
ERROR:
	FEerror("Illegal arguments for bit-array operation.", 0);
856
}