summaryrefslogtreecommitdiff
path: root/srfi/srfi-60.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-09-12 23:18:54 +0200
committerAndy Wingo <wingo@pobox.com>2010-09-12 23:29:11 +0200
commit37710f7e8f63f784de0343c1948e8afbbc10e395 (patch)
tree8d96cda7a538c82c3f981454392d799aafa5c1eb /srfi/srfi-60.c
parent4453f887ed6004126a73673f76853b30263209aa (diff)
downloadguile-37710f7e8f63f784de0343c1948e8afbbc10e395.tar.gz
move srfi-1 and srfi-60 C impl to libguile, without public C api
* libguile/srfi-1.c: * libguile/srfi-1.h: * libguile/srfi-60.c: * libguile/srfi-60.h: * libguile/ChangeLog-srfi: Move here, from the srfi/ dir. The C API is internal. Add API to register the extensions, called by init.c. * libguile/init.c: Verily, register srfi extensions. * libguile/Makefile.am: Add srfi files. * module/srfi/srfi-1.scm: * module/srfi/srfi-60.scm: Update load-extension invocation. * Makefile.am: * configure.ac: Remove srfi/ dir. * test-suite/standalone/Makefile.am: * test-suite/standalone/test-srfi-1.c: Remove srfi-1 C test, we don't support this API any more.
Diffstat (limited to 'srfi/srfi-60.c')
-rw-r--r--srfi/srfi-60.c423
1 files changed, 0 insertions, 423 deletions
diff --git a/srfi/srfi-60.c b/srfi/srfi-60.c
deleted file mode 100644
index 989898f9c..000000000
--- a/srfi/srfi-60.c
+++ /dev/null
@@ -1,423 +0,0 @@
-/* srfi-60.c --- Integers as Bits
- *
- * Copyright (C) 2005, 2006, 2008 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <libguile.h>
-#include <srfi/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 present in @var{n}.\n"
- "This is also the bit index of the lowest 1 bit in @var{n}. If\n"
- "@var{n} is 0, the return is @math{-1}.\n"
- "\n"
- "@example\n"
- "(log2-binary-factors 6) @result{} 1\n"
- "(log2-binary-factors -8) @result{} 3\n"
- "@end example")
-#define FUNC_NAME s_scm_srfi60_log2_binary_factors
-{
- SCM ret = SCM_EOL;
-
- if (SCM_I_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 here, 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 the bit at @var{index} set according to\n"
- "@var{newbit}. @var{newbit} should be @code{#t} to set the bit\n"
- "to 1, or @code{#f} to set it to 0. Bits other than at\n"
- "@var{index} are unchanged in the return.\n"
- "\n"
- "@example\n"
- "(copy-bit 1 #b0101 #t) @result{} 7\n"
- "@end example")
-#define FUNC_NAME s_scm_srfi60_copy_bit
-{
- SCM r;
- unsigned long ii;
- int bb;
-
- ii = scm_to_ulong (index);
- bb = scm_to_bool (bit);
-
- if (SCM_I_INUMP (n))
- {
- long nn = SCM_I_INUM (n);
-
- /* can't set high bit ii==SCM_LONG_BIT-1, that would change the sign,
- which is not what's wanted */
- if (ii < SCM_LONG_BIT-1)
- {
- nn &= ~(1L << ii); /* zap bit at index */
- nn |= ((long) bb << ii); /* insert desired bit */
- return scm_from_long (nn);
- }
- else
- {
- /* bits at ii==SCM_LONG_BIT-1 and above are all copies of the sign
- bit, if this is already the desired "bit" value then no need to
- make a new bignum value */
- if (bb == (nn < 0))
- return n;
-
- r = scm_i_long2big (nn);
- goto big;
- }
- }
- else if (SCM_BIGP (n))
- {
- /* if the bit is already what's wanted then no need to make a new
- bignum */
- if (bb == mpz_tstbit (SCM_I_BIG_MPZ (n), ii))
- return 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 bit field from @var{start} (inclusive)\n"
- "to @var{end} (exclusive) rotated upwards by @var{count} bits.\n"
- "\n"
- "@var{count} can be positive or negative, and it can be more\n"
- "than the field width (it'll be reduced modulo the width).\n"
- "\n"
- "@example\n"
- "(rotate-bit-field #b0110 2 1 4) @result{} #b1010\n"
- "@end example")
-#define FUNC_NAME s_scm_srfi60_rotate_bit_field
-{
- unsigned long ss = scm_to_ulong (start);
- unsigned long ee = scm_to_ulong (end);
- unsigned long ww, cc;
-
- SCM_ASSERT_RANGE (3, end, (ee >= ss));
- ww = ee - ss;
-
- cc = scm_to_ulong (scm_modulo (count, scm_difference (end, start)));
-
- if (SCM_I_INUMP (n))
- {
- long nn = SCM_I_INUM (n);
-
- if (ee <= SCM_LONG_BIT-1)
- {
- /* 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
- {
- /* either no movement, or a field of only 0 or 1 bits, result
- unchanged, avoid creating a bignum */
- if (cc == 0 || ww <= 1)
- return n;
-
- 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, result
- unchanged, avoid creating a new bignum */
- 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);
-
- /* bits moved around might leave us in range of an inum */
- 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 between @var{start} (inclusive) to\n"
- "@var{end} (exclusive) reversed.\n"
- "\n"
- "@example\n"
- "(reverse-bit-field #b101001 2 4) @result{} #b100101\n"
- "@end example")
-#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_I_INUMP (n))
- {
- long nn = SCM_I_INUM (n);
-
- if (ee <= SCM_LONG_BIT-1)
- {
- /* 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
- {
- /* avoid creating a new bignum if reversing only 0 or 1 bits */
- if (ee - ss <= 1)
- return n;
-
- 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);
- int ebit = mpz_tstbit (SCM_I_BIG_MPZ (b), ee);
- 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 bits from @var{n} in the form of a list of @code{#t} for\n"
- "1 and @code{#f} for 0. The least significant @var{len} bits\n"
- "are returned, and the first list element is the most\n"
- "significant of those bits. If @var{len} is not given, the\n"
- "default is @code{(integer-length @var{n})} (@pxref{Bitwise\n"
- "Operations}).\n"
- "\n"
- "@example\n"
- "(integer->list 6) @result{} (#t #t #f)\n"
- "(integer->list 1 4) @result{} (#f #f #f #t)\n"
- "@end example")
-#define FUNC_NAME s_scm_srfi60_integer_to_list
-{
- SCM ret = SCM_EOL;
- unsigned long ll, i;
-
- if (SCM_UNBNDP (len))
- len = scm_integer_length (n);
- ll = scm_to_ulong (len);
-
- if (SCM_I_INUMP (n))
- {
- long nn = SCM_I_INUM (n);
- for (i = 0; i < ll; i++)
- {
- unsigned long shift =
- (i < ((unsigned long) SCM_LONG_BIT-1))
- ? i : ((unsigned long) SCM_LONG_BIT-1);
- int bit = (nn >> shift) & 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 formed bitwise from the given @var{lst} list\n"
- "of booleans. Each boolean is @code{#t} for a 1 and @code{#f}\n"
- "for a 0. The first element becomes the most significant bit in\n"
- "the return.\n"
- "\n"
- "@example\n"
- "(list->integer '(#t #f #t #f)) @result{} 10\n"
- "@end example")
-#define FUNC_NAME s_scm_srfi60_list_to_integer
-{
- long len;
-
- /* strip high zero bits from lst; after this the length tells us whether
- an inum or bignum is required */
- while (scm_is_pair (lst) && scm_is_false (SCM_CAR (lst)))
- lst = SCM_CDR (lst);
-
- SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, len);
-
- if (len <= SCM_I_FIXNUM_BIT - 1)
- {
- /* fits an inum (a positive inum) */
- 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
- {
- /* need a bignum */
- 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
-
-
-/* note: don't put "scm_srfi60_list_to_integer" arg on its own line, a
- newline breaks the snarfer */
-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
-}