/* srfi-60.c --- Integers as Bits * * Copyright (C) 2005 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */ #include #include "libguile/private-gc.h" /* for SCM_MIN */ #include "srfi-60.h" SCM_DEFINE (scm_srfi60_log2_binary_factors, "log2-binary-factors", 1, 0, 0, (SCM n), "Return a count of how many factors of 2 are in @var{N}.\n" "\n" "This is also the bit index of the least significant 1 bit. For\n" "zero, the return is @math{-1}.") #define FUNC_NAME s_scm_srfi60_log2_binary_factors { SCM ret = SCM_EOL; if (SCM_INUMP (n)) { long nn = SCM_I_INUM (n); if (nn == 0) return SCM_I_MAKINUM (-1); nn = nn ^ (nn-1); /* 1 bits for each low 0 and lowest 1 */ return scm_logcount (SCM_I_MAKINUM (nn >> 1)); } else if (SCM_BIGP (n)) { /* no need for scm_remember_upto_here_1, mpz_scan1 doesn't do anything that could result in a gc */ return SCM_I_MAKINUM (mpz_scan1 (SCM_I_BIG_MPZ (n), 0L)); } else SCM_WRONG_TYPE_ARG (SCM_ARG1, n); return ret; } #undef FUNC_NAME SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0, (SCM index, SCM n, SCM bit), "Return @var{n} with bit number @var{index} changed to\n" "@var{bit}. @var{bit} should be @code{#t} to set a 1 or\n" "@code{#f} to set a 0.") #define FUNC_NAME s_scm_srfi60_copy_bit { SCM current_bit, r; long ii; int bb; /* if the bit is already what's wanted then avoid making a new bignum */ current_bit = scm_logbit_p (index, n); if (scm_is_eq (current_bit, bit)) return n; ii = scm_to_long (index); bb = scm_to_bool (bit); if (SCM_INUMP (n)) { long nn = SCM_INUM (n); /* in a 32 bit word, can handle index up to 30 */ if (ii < SCM_LONG_BIT-1) { nn &= ~(1L << ii); /* zap bit at index */ nn |= (bb << ii); /* insert desired bit */ return scm_from_long (nn); } else { r = scm_i_long2big (nn); goto big; } } else if (SCM_BIGP (n)) { r = scm_i_clonebig (n, 1); big: if (bb) mpz_setbit (SCM_I_BIG_MPZ (r), ii); else mpz_clrbit (SCM_I_BIG_MPZ (r), ii); /* changing a high bit might put the result into range of a fixnum */ return scm_i_normbig (r); } else SCM_WRONG_TYPE_ARG (SCM_ARG1, n); } #undef FUNC_NAME SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0, (SCM n, SCM count, SCM start, SCM end), "Return @var{n} with the bits @var{start} (inclusive) to\n" "@var{end} (exclusive) bitwise rotated upwards by @var{count}\n" "bits. @var{count} can be positive or negative.") #define FUNC_NAME s_scm_srfi60_rotate_bit_field { long cc = scm_to_long (scm_modulo (count, scm_difference (end, start))); long ss = scm_to_long (start); long ee = scm_to_long (end); long ww = ee - ss; if (SCM_INUMP (n)) { long nn; /* either no movement, or in a field of only 0 or 1 bits */ if (cc == 0 || ww <= 1) return n; nn = SCM_INUM (n); if (ee <= SCM_LONG_BIT-1) { /* can do it all within a long */ long below = nn & ((1L << ss) - 1); /* before start */ long above = nn & (-1L << ee); /* above end */ long fmask = (-1L << ss) & ((1L << ee) - 1); /* field mask */ long ff = nn & fmask; /* field */ return scm_from_long (above | ((ff << cc) & fmask) | ((ff >> (ww-cc)) & fmask) | below); } else { n = scm_i_long2big (nn); goto big; } } else if (SCM_BIGP (n)) { mpz_t tmp; SCM r; /* either no movement, or in a field of only 0 or 1 bits */ if (cc == 0 || ww <= 1) return n; big: r = scm_i_ulong2big (0); mpz_init (tmp); /* portion above end */ mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (n), ee); mpz_mul_2exp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), ee); /* field high part, width-count bits from start go to start+count */ mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ss); mpz_fdiv_r_2exp (tmp, tmp, ww - cc); mpz_mul_2exp (tmp, tmp, ss + cc); mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp); /* field high part, count bits from end-count go to start */ mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ee - cc); mpz_fdiv_r_2exp (tmp, tmp, cc); mpz_mul_2exp (tmp, tmp, ss); mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp); /* portion below start */ mpz_fdiv_r_2exp (tmp, SCM_I_BIG_MPZ (n), ss); mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp); mpz_clear (tmp); return scm_i_normbig (r); } else SCM_WRONG_TYPE_ARG (SCM_ARG1, n); } #undef FUNC_NAME SCM_DEFINE (scm_srfi60_reverse_bit_field, "reverse-bit-field", 3, 0, 0, (SCM n, SCM start, SCM end), "Return @var{n} with the bits @var{start} (inclusive) to\n" "@var{end} (exclusive) bitwise reversed.") #define FUNC_NAME s_scm_srfi60_reverse_bit_field { long ss = scm_to_long (start); long ee = scm_to_long (end); long swaps = (ee - ss) / 2; /* number of swaps */ SCM b; if (SCM_INUMP (n)) { long nn = SCM_INUM (n); if (ee < SCM_LONG_BIT-1) { /* can do it all within a long */ long smask = 1L << ss; long emask = 1L << (ee-1); for ( ; swaps > 0; swaps--) { long sbit = nn & smask; long ebit = nn & emask; nn ^= sbit ^ (ebit ? smask : 0) /* zap sbit, put ebit value */ ^ ebit ^ (sbit ? emask : 0); /* zap ebit, put sbit value */ smask <<= 1; emask >>= 1; } return scm_from_long (nn); } else { b = scm_i_long2big (nn); goto big; } } else if (SCM_BIGP (n)) { /* avoid creating a new bignum if reversing only 0 or 1 bits */ if (ee - ss <= 1) return n; b = scm_i_clonebig (n, 1); big: ee--; for ( ; swaps > 0; swaps--) { int sbit = (mpz_tstbit (SCM_I_BIG_MPZ (b), ss) != 0); int ebit = (mpz_tstbit (SCM_I_BIG_MPZ (b), ee) != 0); if (sbit ^ ebit) { /* the two bits are different, flip them */ if (sbit) { mpz_clrbit (SCM_I_BIG_MPZ (b), ss); mpz_setbit (SCM_I_BIG_MPZ (b), ee); } else { mpz_setbit (SCM_I_BIG_MPZ (b), ss); mpz_clrbit (SCM_I_BIG_MPZ (b), ee); } } ss++; ee--; } /* swapping zero bits into the high might make us fit a fixnum */ return scm_i_normbig (b); } else SCM_WRONG_TYPE_ARG (SCM_ARG1, n); } #undef FUNC_NAME SCM_DEFINE (scm_srfi60_integer_to_list, "integer->list", 1, 1, 0, (SCM n, SCM len), "Return a list of booleans @code{#t} and #code{#f} representing\n" "the bits of @var{n}. The least significant @var{len} bits are\n" "taken, @var{len} defaults to @code{(integer-length @var{n})}.\n" "The list has the most significant bit first.") #define FUNC_NAME s_scm_srfi60_integer_to_list { SCM ret = SCM_EOL; long ll, i; if (SCM_UNBNDP (len)) len = scm_integer_length (n); ll = scm_to_long (len); if (SCM_INUMP (n)) { long nn = SCM_I_INUM (n); for (i = 0; i < ll; i++) { int bit = (nn >> SCM_MIN (i, SCM_LONG_BIT-1)) & 1; ret = scm_cons (scm_from_bool (bit), ret); } } else if (SCM_BIGP (n)) { for (i = 0; i < ll; i++) ret = scm_cons (scm_from_bool (mpz_tstbit (SCM_I_BIG_MPZ (n), i)), ret); scm_remember_upto_here_1 (n); } else SCM_WRONG_TYPE_ARG (SCM_ARG1, n); return ret; } #undef FUNC_NAME SCM_DEFINE (scm_srfi60_list_to_integer, "list->integer", 1, 0, 0, (SCM lst), "Return an integer ...") #define FUNC_NAME s_scm_srfi60_list_to_integer { long len; SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, len); if (len <= SCM_I_FIXNUM_BIT-1) { long n = 0; while (scm_is_pair (lst)) { n <<= 1; if (! scm_is_false (SCM_CAR (lst))) n++; lst = SCM_CDR (lst); } return SCM_I_MAKINUM (n); } else { SCM n = scm_i_ulong2big (0); while (scm_is_pair (lst)) { len--; if (! scm_is_false (SCM_CAR (lst))) mpz_setbit (SCM_I_BIG_MPZ (n), len); lst = SCM_CDR (lst); } return n; } } #undef FUNC_NAME SCM_REGISTER_PROC (s_srfi60_booleans_to_integer, "booleans->integer", 0, 0, 1, scm_srfi60_list_to_integer); void scm_init_srfi_60 (void) { #ifndef SCM_MAGIC_SNARFER #include "srfi/srfi-60.x" #endif }