* srfi-60
@ 2005-03-09 23:28 Kevin Ryde
0 siblings, 0 replies; only message in thread
From: Kevin Ryde @ 2005-03-09 23:28 UTC (permalink / raw)
[-- Attachment #1: Type: text/plain, Size: 462 bytes --]
I had a bit of a go at the new srfi-60 for the cvs head (below).
There's only a half dozen functions not already in the core.
`bit-count' clashes, in srfi-60 it's an alias for logcount but in the
core it's for bit vectors. I'm not sure what to do with that. It
should be exported, but there'd be a choice between letting the usual
"override" warning come out, or perhaps suppress that and make the new
function accept the args of both the core and srfi-60.
[-- Attachment #2: srfi-60.scm --]
[-- Type: text/plain, Size: 2106 bytes --]
;;; srfi-60.scm --- 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
(define-module (srfi srfi-60)
#:export (bitwise-and
bitwise-ior
bitwise-xor
bitwise-not
any-bits-set?
bit-count
bitwise-if bitwise-merge
log2-binary-factors first-set-bit
bit-set?
copy-bit
bit-field
copy-bit-field
arithmetic-shift
rotate-bit-field
reverse-bit-field
integer->list
list->integer
booleans->integer)
#:re-export (logand
logior
logxor
integer-length
logtest
logcount
logbit?
ash))
(load-extension "libguile-srfi-srfi-60-v-1" "scm_init_srfi_60")
(define bitwise-and logand)
(define bitwise-ior logior)
(define bitwise-xor logxor)
(define bitwise-not lognot)
(define any-bits-set? logtest)
(define bit-count logcount)
(define (bitwise-if mask n0 n1)
(logior (logand mask n0)
(logand (lognot mask) n1)))
(define bitwise-merge bitwise-if)
(define first-set-bit log2-binary-factors)
(define bit-set? logbit?)
(define bit-field bit-extract)
(define (copy-bit-field to from start end)
(logxor to (ash (logxor (bit-extract to start end) ;; zap old
(bit-extract from 0 (- end start))) ;; insert new
start)))
(define arithmetic-shift ash)
(cond-expand-provide (current-module) '(srfi-60))
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: srfi-60.c --]
[-- Type: text/x-csrc, Size: 9899 bytes --]
/* 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 <libguile.h>
#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
}
[-- Attachment #4: Type: text/plain, Size: 143 bytes --]
_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-devel
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2005-03-09 23:28 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2005-03-09 23:28 srfi-60 Kevin Ryde
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).