num_log.d 17.3 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 358
                        big_set_si(x_copy, fix(x));
			bignum_operations[op](x_copy, y);
359
                        return _ecl_big_register_normalize(x_copy);
360 361 362 363 364 365
		}
		default:
			FEtype_error_integer(y);
		}
		break;
	case t_bignum: {
366
                cl_object x_copy = _ecl_big_register0();
367
                big_set(x_copy, x);
368 369
		switch (type_of(y)) {
		case t_fixnum: {
370
			cl_object z = _ecl_big_register1();
371 372
                        big_set_si(z,fix(y));
			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 380 381
			break;
		default:
			FEtype_error_integer(y);
		}
382
                return _ecl_big_register_normalize(x_copy);
383 384 385 386
	}
	default:
		FEtype_error_integer(x);
	}
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 412 413
		if (big_sign(x) >= 0)
			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 430 431 432 433 434 435 436 437 438
		break;
	default:
		FEtype_error_integer(x);
	}
	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 472 473 474
		if (FIXNUMP(x)) {
			mpz_set_si(y->big.big_num, fix(x));
			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 611 612
	} else {
		assert_type_non_negative_integer(p);
		if (FIXNUMP(x))
			i = (fix(x) < 0);
		else
			i = (big_sign(x) < 0);
	}
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 640 641 642 643 644 645 646 647 648 649 650 651
	  else
	    sign_x = big_sign(x);
	  if (big_sign(y) < 0)
	    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 662
cl_object
cl_integer_length(cl_object x)
{
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 (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 685 686 687
		break;
	default:
		FEtype_error_integer(x);
	}
	@(return MAKE_FIXNUM(count))
688
}
jjgarcia's avatar
jjgarcia committed
689

690 691 692
cl_object
si_bit_array_op(cl_object o, cl_object x, cl_object y, cl_object r)
{
jjgarcia's avatar
jjgarcia committed
693 694
	cl_fixnum i, j, n, d;
	cl_object r0;
695
	bit_operator op;
jjgarcia's avatar
jjgarcia committed
696 697 698 699
	bool replace = FALSE;
	int xi, yi, ri;
	byte *xp, *yp, *rp;
	int xo, yo, ro;
700

jjgarcia's avatar
jjgarcia committed
701 702 703 704 705 706 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
	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)) {
734
			r = si_make_vector(@'bit', MAKE_FIXNUM(d), Cnil, Cnil, Cnil, Cnil);
jjgarcia's avatar
jjgarcia committed
735 736 737 738
		}
	} else {
		if (type_of(x) != t_array)
			goto ERROR;
739
		if ((cl_elttype)x->array.elttype != aet_bit)
jjgarcia's avatar
jjgarcia committed
740 741 742 743 744 745
			goto ERROR;
		d = x->array.dim;
		xp = x->vector.self.bit;
		xo = x->vector.offset;
		if (type_of(y) != t_array)
			goto ERROR;
746
		if ((cl_elttype)y->array.elttype != aet_bit)
jjgarcia's avatar
jjgarcia committed
747 748 749 750 751 752 753 754 755 756 757 758 759
			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;
760
			if ((cl_elttype)r->array.elttype != aet_bit)
jjgarcia's avatar
jjgarcia committed
761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782
				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)) {
783
		  r = ecl_alloc_object(t_array);
jjgarcia's avatar
jjgarcia committed
784 785
		  r->array.self.t = NULL;
		  r->array.displaced = Cnil;
jjgarcia's avatar
jjgarcia committed
786 787 788
		  r->array.rank = x->array.rank;
		  r->array.dims = x->array.dims;
		  r->array.elttype = aet_bit;
jjgarcia's avatar
jjgarcia committed
789
		  r->array.dim = x->array.dim;
790
		  r->array.flags = 0; /* no fill pointer, not adjustable */
791
		  ecl_array_allocself(r);
jjgarcia's avatar
jjgarcia committed
792 793 794 795
		}
	}
	rp = r->vector.self.bit;
	ro = r->vector.offset;
796
	op = fixnum_operations[coerce_to_logical_operator(o)];
jjgarcia's avatar
jjgarcia committed
797 798 799 800 801 802 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

#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);
850
}