diff options
author | Andy Wingo <wingo@pobox.com> | 2010-09-12 23:18:54 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-09-12 23:29:11 +0200 |
commit | 37710f7e8f63f784de0343c1948e8afbbc10e395 (patch) | |
tree | 8d96cda7a538c82c3f981454392d799aafa5c1eb /srfi/srfi-60.c | |
parent | 4453f887ed6004126a73673f76853b30263209aa (diff) | |
download | guile-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.c | 423 |
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 -} |