1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* Arithmetic Utilities */
28
29 #include "scheme.h"
30 #include "bits.h"
31
32 /* Conversions between Scheme types and C types. */
33
34 long
fixnum_to_long(SCHEME_OBJECT fixnum)35 fixnum_to_long (SCHEME_OBJECT fixnum)
36 {
37 return (FIXNUM_TO_LONG (fixnum));
38 }
39
40 SCHEME_OBJECT
double_to_fixnum(double value)41 double_to_fixnum (double value)
42 {
43 #ifdef HAVE_DOUBLE_TO_LONG_BUG
44 long temp = ((long) value);
45 return (LONG_TO_FIXNUM (temp));
46 #else
47 return (LONG_TO_FIXNUM ((long) value));
48 #endif
49 }
50
51 bool
integer_to_long_p(SCHEME_OBJECT n)52 integer_to_long_p (SCHEME_OBJECT n)
53 {
54 return ((FIXNUM_P (n)) || (BIGNUM_TO_LONG_P (n)));
55 }
56
57 long
integer_to_long(SCHEME_OBJECT n)58 integer_to_long (SCHEME_OBJECT n)
59 {
60 return ((FIXNUM_P (n)) ? (FIXNUM_TO_LONG (n)) : (bignum_to_long (n)));
61 }
62
63 bool
integer_to_intmax_p(SCHEME_OBJECT n)64 integer_to_intmax_p (SCHEME_OBJECT n)
65 {
66 return ((FIXNUM_P (n)) || (BIGNUM_TO_INTMAX_P (n)));
67 }
68
69 intmax_t
integer_to_intmax(SCHEME_OBJECT n)70 integer_to_intmax (SCHEME_OBJECT n)
71 {
72 return ((FIXNUM_P (n)) ? (FIXNUM_TO_LONG (n)) : (bignum_to_intmax (n)));
73 }
74
75 SCHEME_OBJECT
long_to_integer(long number)76 long_to_integer (long number)
77 {
78 return
79 ((LONG_TO_FIXNUM_P (number))
80 ? (LONG_TO_FIXNUM (number))
81 : (long_to_bignum (number)));
82 }
83
84 SCHEME_OBJECT
intmax_to_integer(intmax_t number)85 intmax_to_integer (intmax_t number)
86 {
87 return
88 (((LONG_MIN <= number) && (number <= LONG_MAX))
89 ? (long_to_integer (number))
90 : (intmax_to_bignum (number)));
91 }
92
93 bool
integer_to_ulong_p(SCHEME_OBJECT n)94 integer_to_ulong_p (SCHEME_OBJECT n)
95 {
96 return ((FIXNUM_P (n)) ? (!FIXNUM_NEGATIVE_P (n)) : (BIGNUM_TO_ULONG_P (n)));
97 }
98
99 unsigned long
integer_to_ulong(SCHEME_OBJECT n)100 integer_to_ulong (SCHEME_OBJECT n)
101 {
102 return ((FIXNUM_P (n))
103 ? ((unsigned long) (FIXNUM_TO_LONG (n)))
104 : (bignum_to_ulong (n)));
105 }
106
107 bool
integer_to_uintmax_p(SCHEME_OBJECT n)108 integer_to_uintmax_p (SCHEME_OBJECT n)
109 {
110 return
111 ((FIXNUM_P (n)) ? (!FIXNUM_NEGATIVE_P (n)) : (BIGNUM_TO_UINTMAX_P (n)));
112 }
113
114 uintmax_t
integer_to_uintmax(SCHEME_OBJECT n)115 integer_to_uintmax (SCHEME_OBJECT n)
116 {
117 return ((FIXNUM_P (n))
118 ? ((uintmax_t) (FIXNUM_TO_LONG (n)))
119 : (bignum_to_uintmax (n)));
120 }
121
122 SCHEME_OBJECT
ulong_to_integer(unsigned long number)123 ulong_to_integer (unsigned long number)
124 {
125 long s_number = ((long) number);
126 if (s_number >= 0)
127 return
128 ((LONG_TO_FIXNUM_P (s_number))
129 ? (LONG_TO_FIXNUM (s_number))
130 : (long_to_bignum (s_number)));
131 else
132 return (ulong_to_bignum (number));
133 }
134
135 SCHEME_OBJECT
uintmax_to_integer(uintmax_t number)136 uintmax_to_integer (uintmax_t number)
137 {
138 return ((number <= ULONG_MAX)
139 ? (ulong_to_integer (number))
140 : (uintmax_to_bignum (number)));
141 }
142
143 bool
integer_to_double_p(SCHEME_OBJECT n)144 integer_to_double_p (SCHEME_OBJECT n)
145 {
146 return ((FIXNUM_P (n)) || (BIGNUM_TO_DOUBLE_P (n)));
147 }
148
149 double
integer_to_double(SCHEME_OBJECT n)150 integer_to_double (SCHEME_OBJECT n)
151 {
152 return ((FIXNUM_P (n)) ? (FIXNUM_TO_DOUBLE (n)) : (bignum_to_double (n)));
153 }
154
155 SCHEME_OBJECT
double_to_integer(double x)156 double_to_integer (double x)
157 {
158 return
159 ((DOUBLE_TO_FIXNUM_P (x))
160 ? (DOUBLE_TO_FIXNUM (x))
161 : (double_to_bignum (x)));
162 }
163
164 double
double_truncate(double x)165 double_truncate (double x)
166 {
167 double iptr;
168 (void) modf (x, (&iptr));
169 return (iptr);
170 }
171
172 double
double_round(double x)173 double_round (double x)
174 {
175 double integral;
176 double fractional = (fabs (modf (x, (&integral))));
177
178 if ((fractional == 0.5)
179 ? ((fmod (integral, 2.0)) == 0.0)
180 : (! (0.5 < fractional)))
181 return (integral);
182 else if (x < 0.0)
183 return (integral - 1.0);
184 else
185 return (integral + 1.0);
186 }
187
188 /* Conversions between Scheme types and Scheme types. */
189
190 SCHEME_OBJECT
bignum_to_fixnum(SCHEME_OBJECT bignum)191 bignum_to_fixnum (SCHEME_OBJECT bignum)
192 {
193 return
194 ((BIGNUM_TO_FIXNUM_P (bignum))
195 ? (BIGNUM_TO_FIXNUM (bignum))
196 : SHARP_F);
197 }
198
199 SCHEME_OBJECT
bignum_to_integer(SCHEME_OBJECT bignum)200 bignum_to_integer (SCHEME_OBJECT bignum)
201 {
202 return
203 ((BIGNUM_TO_FIXNUM_P (bignum))
204 ? (BIGNUM_TO_FIXNUM (bignum))
205 : bignum);
206 }
207
208 SCHEME_OBJECT
bignum_to_flonum(SCHEME_OBJECT bignum)209 bignum_to_flonum (SCHEME_OBJECT bignum)
210 {
211 return
212 ((BIGNUM_TO_FLONUM_P (bignum))
213 ? (BIGNUM_TO_FLONUM (bignum))
214 : SHARP_F);
215 }
216
217 bool
finite_flonum_p(SCHEME_OBJECT x)218 finite_flonum_p (SCHEME_OBJECT x)
219 {
220 return ((FLONUM_P (x)) && (flonum_is_finite_p (x)));
221 }
222
223 bool
flonum_is_finite_p(SCHEME_OBJECT x)224 flonum_is_finite_p (SCHEME_OBJECT x)
225 {
226 return double_is_finite_p (FLONUM_TO_DOUBLE (x));
227 }
228
229 bool
double_is_finite_p(double x)230 double_is_finite_p (double x)
231 {
232 return
233 (((x > 1.0) || (x < -1.0))
234 ? (x != (x / 2.0))
235 : ((x <= 1.0) && (x >= -1.0)));
236 }
237
238 bool
flonum_integer_p(SCHEME_OBJECT x)239 flonum_integer_p (SCHEME_OBJECT x)
240 {
241 double iptr;
242 return ((modf ((FLONUM_TO_DOUBLE (x)), (&iptr))) == 0);
243 }
244
245 SCHEME_OBJECT
flonum_floor(SCHEME_OBJECT x)246 flonum_floor (SCHEME_OBJECT x)
247 {
248 return (double_to_flonum (floor (FLONUM_TO_DOUBLE (x))));
249 }
250
251 SCHEME_OBJECT
flonum_ceiling(SCHEME_OBJECT x)252 flonum_ceiling (SCHEME_OBJECT x)
253 {
254 return (double_to_flonum (ceil (FLONUM_TO_DOUBLE (x))));
255 }
256
257 SCHEME_OBJECT
flonum_round(SCHEME_OBJECT x)258 flonum_round (SCHEME_OBJECT x)
259 {
260 return (double_to_flonum (double_round (FLONUM_TO_DOUBLE (x))));
261 }
262
263 SCHEME_OBJECT
flonum_normalize(SCHEME_OBJECT x)264 flonum_normalize (SCHEME_OBJECT x)
265 {
266 int exponent;
267 double significand = (frexp ((FLONUM_TO_DOUBLE (x)), (&exponent)));
268 return (cons ((double_to_flonum (significand)),
269 (long_to_integer ((long) exponent))));
270 }
271
272 SCHEME_OBJECT
flonum_denormalize(SCHEME_OBJECT x,SCHEME_OBJECT e)273 flonum_denormalize (SCHEME_OBJECT x, SCHEME_OBJECT e)
274 {
275 return (double_to_flonum (ldexp ((FLONUM_TO_DOUBLE (x)),
276 ((int) (integer_to_long (e))))));
277 }
278
279 /* Generic Integer Operations */
280
281 bool
integer_zero_p(SCHEME_OBJECT n)282 integer_zero_p (SCHEME_OBJECT n)
283 {
284 return ((FIXNUM_P (n)) ? (FIXNUM_ZERO_P (n)) : (BIGNUM_ZERO_P (n)));
285 }
286
287 bool
integer_negative_p(SCHEME_OBJECT n)288 integer_negative_p (SCHEME_OBJECT n)
289 {
290 return ((FIXNUM_P (n)) ? (FIXNUM_NEGATIVE_P (n)) : (BIGNUM_NEGATIVE_P (n)));
291 }
292
293 bool
integer_positive_p(SCHEME_OBJECT n)294 integer_positive_p (SCHEME_OBJECT n)
295 {
296 return ((FIXNUM_P (n)) ? (FIXNUM_POSITIVE_P (n)) : (BIGNUM_POSITIVE_P (n)));
297 }
298
299 bool
integer_equal_p(SCHEME_OBJECT n,SCHEME_OBJECT m)300 integer_equal_p (SCHEME_OBJECT n, SCHEME_OBJECT m)
301 {
302 return
303 ((FIXNUM_P (n))
304 ? ((FIXNUM_P (m))
305 ? (FIXNUM_EQUAL_P (n, m))
306 : (bignum_equal_p ((FIXNUM_TO_BIGNUM (n)), m)))
307 : (bignum_equal_p (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m))));
308 }
309
310 bool
integer_less_p(SCHEME_OBJECT n,SCHEME_OBJECT m)311 integer_less_p (SCHEME_OBJECT n, SCHEME_OBJECT m)
312 {
313 return
314 ((FIXNUM_P (n))
315 ? ((FIXNUM_P (m))
316 ? (FIXNUM_LESS_P (n, m))
317 : (BIGNUM_LESS_P ((FIXNUM_TO_BIGNUM (n)), m)))
318 : (BIGNUM_LESS_P (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m))));
319 }
320
321 SCHEME_OBJECT
integer_negate(SCHEME_OBJECT n)322 integer_negate (SCHEME_OBJECT n)
323 {
324 return
325 ((FIXNUM_P (n))
326 ? (long_to_integer (- (FIXNUM_TO_LONG (n))))
327 : (bignum_to_integer (bignum_negate (n))));
328 }
329
330 SCHEME_OBJECT
integer_add(SCHEME_OBJECT n,SCHEME_OBJECT m)331 integer_add (SCHEME_OBJECT n, SCHEME_OBJECT m)
332 {
333 return
334 ((FIXNUM_P (n))
335 ? ((FIXNUM_P (m))
336 ? (long_to_integer ((FIXNUM_TO_LONG (n)) + (FIXNUM_TO_LONG (m))))
337 : (bignum_to_integer (bignum_add ((FIXNUM_TO_BIGNUM (n)), m))))
338 : (bignum_to_integer
339 (bignum_add (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m)))));
340 }
341
342 SCHEME_OBJECT
integer_add_1(SCHEME_OBJECT n)343 integer_add_1 (SCHEME_OBJECT n)
344 {
345 return
346 ((FIXNUM_P (n))
347 ? (long_to_integer ((FIXNUM_TO_LONG (n)) + 1))
348 : (bignum_to_integer (bignum_add (n, (long_to_bignum (1))))));
349 }
350
351 SCHEME_OBJECT
integer_subtract(SCHEME_OBJECT n,SCHEME_OBJECT m)352 integer_subtract (SCHEME_OBJECT n, SCHEME_OBJECT m)
353 {
354 return
355 ((FIXNUM_P (n))
356 ? ((FIXNUM_P (m))
357 ? (long_to_integer ((FIXNUM_TO_LONG (n)) - (FIXNUM_TO_LONG (m))))
358 : (bignum_to_integer (bignum_subtract ((FIXNUM_TO_BIGNUM (n)), m))))
359 : (bignum_to_integer
360 (bignum_subtract (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m)))));
361 }
362
363 SCHEME_OBJECT
integer_subtract_1(SCHEME_OBJECT n)364 integer_subtract_1 (SCHEME_OBJECT n)
365 {
366 return
367 ((FIXNUM_P (n))
368 ? (long_to_integer ((FIXNUM_TO_LONG (n)) - 1))
369 : (bignum_to_integer (bignum_subtract (n, (long_to_bignum (1))))));
370 }
371
372 SCHEME_OBJECT
integer_multiply(SCHEME_OBJECT n,SCHEME_OBJECT m)373 integer_multiply (SCHEME_OBJECT n, SCHEME_OBJECT m)
374 {
375 SCHEME_OBJECT result;
376 return
377 ((FIXNUM_P (n))
378 ? ((FIXNUM_P (m))
379 ? ((result = (Mul (n, m))),
380 ((result != SHARP_F)
381 ? result
382 : (bignum_to_integer
383 (bignum_multiply ((FIXNUM_TO_BIGNUM (n)),
384 (FIXNUM_TO_BIGNUM (m)))))))
385 : (bignum_to_integer (bignum_multiply ((FIXNUM_TO_BIGNUM (n)), m))))
386 : (bignum_to_integer
387 (bignum_multiply (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m)))));
388 }
389
390 bool
integer_divide(SCHEME_OBJECT n,SCHEME_OBJECT d,SCHEME_OBJECT * q,SCHEME_OBJECT * r)391 integer_divide (SCHEME_OBJECT n, SCHEME_OBJECT d,
392 SCHEME_OBJECT * q, SCHEME_OBJECT * r)
393 {
394 if (FIXNUM_P (n))
395 {
396 if (FIXNUM_P (d))
397 {
398 /* Now, unbelievable hair because C doesn't fully specify
399 / and % when their arguments are negative. We must get
400 consistent answers for all valid arguments. */
401 long lx = (FIXNUM_TO_LONG (n));
402 long ly = (FIXNUM_TO_LONG (d));
403 long quotient;
404 long remainder;
405 if (ly == 0)
406 return (true);
407 if (lx < 0)
408 {
409 lx = (-lx);
410 if (ly < 0)
411 {
412 ly = (-ly);
413 quotient = (lx / ly);
414 }
415 else
416 quotient = (- (lx / ly));
417 remainder = (- (lx % ly));
418 }
419 else
420 {
421 if (ly < 0)
422 {
423 ly = (-ly);
424 quotient = (- (lx / ly));
425 }
426 else
427 quotient = (lx / ly);
428 remainder = (lx % ly);
429 }
430 (*q) = (long_to_integer (quotient));
431 (*r) = (LONG_TO_FIXNUM (remainder));
432 return (false);
433 }
434 n = (FIXNUM_TO_BIGNUM (n));
435 }
436 else
437 {
438 if (FIXNUM_P (d))
439 d = (FIXNUM_TO_BIGNUM (d));
440 }
441 {
442 SCHEME_OBJECT quotient;
443 SCHEME_OBJECT remainder;
444 if (bignum_divide (n, d, ("ient), (&remainder)))
445 return (true);
446 (*q) = (bignum_to_integer (quotient));
447 (*r) = (bignum_to_integer (remainder));
448 return (false);
449 }
450 }
451
452 SCHEME_OBJECT
integer_quotient(SCHEME_OBJECT n,SCHEME_OBJECT d)453 integer_quotient (SCHEME_OBJECT n, SCHEME_OBJECT d)
454 {
455 if (FIXNUM_P (n))
456 {
457 if (FIXNUM_P (d))
458 {
459 long lx = (FIXNUM_TO_LONG (n));
460 long ly = (FIXNUM_TO_LONG (d));
461 return
462 ((ly == 0)
463 ? SHARP_F
464 : (long_to_integer
465 ((lx < 0)
466 ? ((ly < 0)
467 ? ((-lx) / (-ly))
468 : (- ((-lx) / ly)))
469 : ((ly < 0)
470 ? (- (lx / (-ly)))
471 : (lx / ly)))));
472 }
473 n = (FIXNUM_TO_BIGNUM (n));
474 }
475 else
476 {
477 if (FIXNUM_P (d))
478 d = (FIXNUM_TO_BIGNUM (d));
479 }
480 {
481 SCHEME_OBJECT result = (bignum_quotient (n, d));
482 return ((result == SHARP_F) ? SHARP_F : (bignum_to_integer (result)));
483 }
484 }
485
486 SCHEME_OBJECT
integer_remainder(SCHEME_OBJECT n,SCHEME_OBJECT d)487 integer_remainder (SCHEME_OBJECT n, SCHEME_OBJECT d)
488 {
489 if (FIXNUM_P (n))
490 {
491 if (FIXNUM_P (d))
492 {
493 long lx = (FIXNUM_TO_LONG (n));
494 long ly = (FIXNUM_TO_LONG (d));
495 return
496 ((ly == 0)
497 ? SHARP_F
498 : (long_to_integer
499 ((lx < 0)
500 ? (- ((-lx) % ((ly < 0) ? (-ly) : ly)))
501 : (lx % ((ly < 0) ? (-ly) : ly)))));
502 }
503 n = (FIXNUM_TO_BIGNUM (n));
504 }
505 else
506 {
507 if (FIXNUM_P (d))
508 d = (FIXNUM_TO_BIGNUM (d));
509 }
510 {
511 SCHEME_OBJECT result = (bignum_remainder (n, d));
512 return
513 ((result == SHARP_F)
514 ? SHARP_F
515 : (bignum_to_integer (result)));
516 }
517 }
518
519 /* Length and Bit Counts */
520
521 /* Ones-complement length. */
522
523 SCHEME_OBJECT
integer_length_in_bits(SCHEME_OBJECT n)524 integer_length_in_bits (SCHEME_OBJECT n)
525 {
526 if (FIXNUM_P (n))
527 {
528 long n1 = (FIXNUM_TO_LONG (n));
529 return (ULONG_TO_FIXNUM (ulong_length_in_bits ((n1 < 0) ? (- n1) : n1)));
530 }
531 else
532 return (ulong_to_integer (bignum_length_in_bits (n)));
533 }
534
535 /* Two's-complement length. */
536
537 SCHEME_OBJECT
integer_length(SCHEME_OBJECT n)538 integer_length (SCHEME_OBJECT n)
539 {
540 if (FIXNUM_P (n))
541 {
542 long n1 = (FIXNUM_TO_LONG (n));
543 return (ULONG_TO_FIXNUM (ulong_length_in_bits ((n1 < 0) ? (~n1) : n1)));
544 }
545 else
546 return (ulong_to_integer (bignum_integer_length (n)));
547 }
548
549 SCHEME_OBJECT
integer_first_set_bit(SCHEME_OBJECT n)550 integer_first_set_bit (SCHEME_OBJECT n)
551 {
552 if (FIXNUM_P (n))
553 {
554 long n1 = (FIXNUM_TO_LONG (n));
555 return
556 (LONG_TO_FIXNUM
557 (ulong_first_set_bit ((n1 < 0) ? (~ ((unsigned long) (~n1))) : n1)));
558 }
559 else
560 return (long_to_integer (bignum_first_set_bit (n)));
561 }
562
563 SCHEME_OBJECT
integer_bit_count(SCHEME_OBJECT n)564 integer_bit_count (SCHEME_OBJECT n)
565 {
566 if (FIXNUM_P (n))
567 {
568 long n1 = (FIXNUM_TO_LONG (n));
569 return (ULONG_TO_FIXNUM (ulong_bit_count ((n1 < 0) ? (~n1) : n1)));
570 }
571 else
572 return (ulong_to_integer (bignum_bit_count (n)));
573 }
574
575 SCHEME_OBJECT
integer_hamming_distance(SCHEME_OBJECT n,SCHEME_OBJECT m)576 integer_hamming_distance (SCHEME_OBJECT n, SCHEME_OBJECT m)
577 {
578 if ((FIXNUM_P (n)) && (FIXNUM_P (m)))
579 {
580 long x = ((FIXNUM_TO_LONG (n)) ^ (FIXNUM_TO_LONG (m)));
581 return
582 ((x < 0)
583 ? (LONG_TO_FIXNUM (-1))
584 : (ULONG_TO_FIXNUM (ulong_bit_count (x))));
585 }
586 else
587 return
588 (long_to_integer
589 (bignum_hamming_distance
590 (((FIXNUM_P (n)) ? (FIXNUM_TO_BIGNUM (n)) : n),
591 ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m))));
592 }
593
594 /* Bitwise Operations */
595
596 SCHEME_OBJECT
integer_bitwise_not(SCHEME_OBJECT n)597 integer_bitwise_not (SCHEME_OBJECT n)
598 {
599 if (FIXNUM_P (n))
600 return (LONG_TO_FIXNUM (~ (FIXNUM_TO_LONG (n))));
601 else
602 return (bignum_bitwise_not (n));
603 }
604
605 #define DEFINE_BITWISE(NAME, OP) \
606 SCHEME_OBJECT \
607 NAME (SCHEME_OBJECT n, SCHEME_OBJECT m) \
608 { \
609 if ((FIXNUM_P (n)) && (FIXNUM_P (m))) \
610 return \
611 (LONG_TO_FIXNUM \
612 (BITWISE_##OP ((FIXNUM_TO_LONG (n)), (FIXNUM_TO_LONG (m))))); \
613 else \
614 return \
615 (bignum_to_integer \
616 (bignum_bitwise_##OP \
617 (((FIXNUM_P (n)) ? (FIXNUM_TO_BIGNUM (n)) : n), \
618 ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m)))); \
619 }
620
621 #define BITWISE_and(x, y) ((x) & (y))
622 #define BITWISE_andc2(x, y) ((x) &~ (y))
623 #define BITWISE_andc1(x, y) ((y) &~ (x))
624 #define BITWISE_xor(x, y) ((x) ^ (y))
625 #define BITWISE_ior(x, y) ((x) | (y))
626 #define BITWISE_nor(x, y) (~ ((x) | (y)))
627 #define BITWISE_eqv(x, y) (~ ((x) ^ (y)))
628 #define BITWISE_orc2(x, y) ((x) |~ (y))
629 #define BITWISE_orc1(x, y) ((y) |~ (x))
630 #define BITWISE_nand(x, y) (~ ((x) & (y)))
631
DEFINE_BITWISE(integer_bitwise_and,and)632 DEFINE_BITWISE (integer_bitwise_and, and)
633 DEFINE_BITWISE (integer_bitwise_andc2, andc2)
634 DEFINE_BITWISE (integer_bitwise_andc1, andc1)
635 DEFINE_BITWISE (integer_bitwise_xor, xor)
636 DEFINE_BITWISE (integer_bitwise_ior, ior)
637 DEFINE_BITWISE (integer_bitwise_nor, nor)
638 DEFINE_BITWISE (integer_bitwise_eqv, eqv)
639 DEFINE_BITWISE (integer_bitwise_orc2, orc2)
640 DEFINE_BITWISE (integer_bitwise_orc1, orc1)
641 DEFINE_BITWISE (integer_bitwise_nand, nand)
642
643 SCHEME_OBJECT
644 integer_nonnegative_one_bits (unsigned long n, unsigned long m)
645 {
646 if (n == 0)
647 return (LONG_TO_FIXNUM (0));
648 else if ((n + m) <= FIXNUM_LENGTH)
649 return (ULONG_TO_FIXNUM ((~ ((~ ((unsigned long) 0)) << n)) << m));
650 else
651 return (bignum_nonnegative_one_bits (n, m));
652 }
653
654 SCHEME_OBJECT
integer_negative_zero_bits(unsigned long n,unsigned long m)655 integer_negative_zero_bits (unsigned long n, unsigned long m)
656 {
657 if (n == 0)
658 return (LONG_TO_FIXNUM (-1));
659 else if ((n + m) <= FIXNUM_LENGTH)
660 return
661 (LONG_TO_FIXNUM (~ ((long) ((~ ((~ ((unsigned long) 0)) << n)) << m))));
662 else
663 return (bignum_negative_zero_bits (n, m));
664 }
665
666 /* Shift: multiplication and Euclidean division by 2^m */
667
668 SCHEME_OBJECT
integer_shift_left(SCHEME_OBJECT n,unsigned long m)669 integer_shift_left (SCHEME_OBJECT n, unsigned long m)
670 {
671 if (m == 0)
672 return (n);
673 if (FIXNUM_P (n))
674 {
675 long n1 = (FIXNUM_TO_LONG (n));
676 if (n1 < 0)
677 {
678 if ((m + (ulong_length_in_bits (~n1))) <= FIXNUM_LENGTH)
679 /* The behaviour of shifting a negative integer is
680 undefined in C. */
681 return (LONG_TO_FIXNUM (- ((-n1) << m)));
682 else
683 return
684 (bignum_negate (unsigned_long_to_shifted_bignum ((-n1), m, 0)));
685 }
686 else if (0 < n1)
687 {
688 if ((m + (ulong_length_in_bits (n1))) <= FIXNUM_LENGTH)
689 return (LONG_TO_FIXNUM (n1 << m));
690 else
691 return (unsigned_long_to_shifted_bignum (n1, m, 0));
692 }
693 else
694 return (LONG_TO_FIXNUM (0));
695 }
696 else
697 return (bignum_shift_left (n, m));
698 }
699
700 SCHEME_OBJECT
integer_shift_right(SCHEME_OBJECT n,unsigned long m)701 integer_shift_right (SCHEME_OBJECT n, unsigned long m)
702 {
703 if (m == 0)
704 return (n);
705 if (FIXNUM_P (n))
706 {
707 long n1 = (FIXNUM_TO_LONG (n));
708 return (LONG_TO_FIXNUM ((n1 < 0) ? (~ ((~n1) >> m)) : (n1 >> m)));
709 }
710 else
711 return (bignum_to_integer (bignum_shift_right (n, m)));
712 }
713