From 99d8c585f9097caee5a63944a9bb942a8fffc044 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 14 Dec 2009 13:46:04 +0900 Subject: [PATCH] adding srfi-33 support (needs testing) --- Makefile | 2 +- config.scm | 4 +- include/chibi/bignum.h | 2 + init.scm | 2 +- lib/srfi/33.module | 17 +++ lib/srfi/33/bit.c | 276 ++++++++++++++++++++++++++++++++++++++++ lib/srfi/33/bitwise.scm | 58 +++++++++ opt/bignum.c | 2 +- 8 files changed, 358 insertions(+), 5 deletions(-) create mode 100644 lib/srfi/33.module create mode 100644 lib/srfi/33/bit.c create mode 100644 lib/srfi/33/bitwise.scm diff --git a/Makefile b/Makefile index 17f935f2..e86023d1 100644 --- a/Makefile +++ b/Makefile @@ -53,7 +53,7 @@ endif all: chibi-scheme$(EXE) libs -COMPILED_LIBS := lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ +COMPILED_LIBS := lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \ lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/posix$(SO) libs: $(COMPILED_LIBS) diff --git a/config.scm b/config.scm index 84bbfb68..d71f8180 100644 --- a/config.scm +++ b/config.scm @@ -156,13 +156,13 @@ (let ((exports '(define set! let let* letrec lambda if cond case delay - and or begin do quote quasiquote unquote unquote-splicing + and or begin do quote quasiquote define-syntax let-syntax letrec-syntax syntax-rules eqv? eq? equal? not boolean? number? complex? real? rational? integer? exact? inexact? = < > <= >= zero? positive? negative? odd? even? max min + * - / abs quotient remainder modulo gcd lcm numerator denominator floor ceiling truncate round exp log sin cos tan asin acos atan sqrt - expt make-rectangular make-polar real-part imag-part magnitude angle + expt real-part imag-part magnitude angle exact->inexact inexact->exact number->string string->number pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr diff --git a/include/chibi/bignum.h b/include/chibi/bignum.h index 8a160c52..580b0a7d 100644 --- a/include/chibi/bignum.h +++ b/include/chibi/bignum.h @@ -19,6 +19,8 @@ sexp_sint_t sexp_bignum_compare (sexp a, sexp b); sexp sexp_compare (sexp ctx, sexp a, sexp b); sexp sexp_make_bignum (sexp ctx, sexp_uint_t len); sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len); +sexp sexp_bignum_normalize (sexp a); +sexp_uint_t sexp_bignum_hi (sexp a); sexp sexp_fixnum_to_bignum (sexp ctx, sexp a); double sexp_bignum_to_double (sexp a); sexp sexp_double_to_bignum (sexp ctx, double f); diff --git a/init.scm b/init.scm index d554bbce..ce2fe440 100644 --- a/init.scm +++ b/init.scm @@ -471,7 +471,7 @@ (let lp ((n n) (d (car o)) (res '())) (if (> n 0) (lp (quotient n d) d (cons (digit-char (remainder n d)) res)) - (list->string res))))) + (if (null? res) "0" (list->string res)))))) (define (string->number str . o) (let ((res diff --git a/lib/srfi/33.module b/lib/srfi/33.module new file mode 100644 index 00000000..81fa0a80 --- /dev/null +++ b/lib/srfi/33.module @@ -0,0 +1,17 @@ + +(define-module (srfi 33) + (export bitwise-not + bitwise-and bitwise-ior + bitwise-xor bitwise-eqv + bitwise-nand bitwise-nor + bitwise-andc1 bitwise-andc2 + bitwise-orc1 bitwise-orc2 + arithmetic-shift bit-count integer-length + bitwise-merge + bit-set? any-bits-set? all-bits-set? + first-set-bit + extract-bit-field test-bit-field? clear-bit-field + replace-bit-field copy-bit-field) + (import (scheme)) + (include-shared "33/bit") + (include "33/bitwise.scm")) diff --git a/lib/srfi/33/bit.c b/lib/srfi/33/bit.c new file mode 100644 index 00000000..4af9118c --- /dev/null +++ b/lib/srfi/33/bit.c @@ -0,0 +1,276 @@ + +#include +#include + +#if USE_BIGNUMS +#include +#endif + +static sexp sexp_bit_and (sexp ctx, sexp x, sexp y) { + sexp res; + sexp_sint_t len, i; + if (sexp_fixnump(x)) { + if (sexp_fixnump(y)) + res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y); +#if USE_BIGNUMS + else if (sexp_bignump(y)) + res = sexp_bit_and(ctx, y, x); +#endif + else + res = sexp_type_exception(ctx, "bitwise-and: not an integer", y); +#if USE_BIGNUMS + } else if (sexp_bignump(x)) { + if (sexp_fixnump(y)) { + res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]); + } else if (sexp_bignump(y)) { + if (sexp_bignum_length(x) < sexp_bignum_length(y)) + res = sexp_copy_bignum(ctx, NULL, x, 0); + else + res = sexp_copy_bignum(ctx, NULL, y, 0); + for (i=0, len=sexp_bignum_length(res); i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i= sexp_bignum_length(y)) { + res = sexp_copy_bignum(ctx, NULL, x, 0); + len = sexp_bignum_length(y); + } else { + res = sexp_copy_bignum(ctx, NULL, y, 0); + len = sexp_bignum_length(x); + } + for (i=0; i> -c); + } else { + tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c; +#if USE_BIGNUMS + if (((tmp >> c) == sexp_unbox_fixnum(i)) + && (tmp < SEXP_MAX_FIXNUM) && (tmp > SEXP_MIN_FIXNUM)) { +#endif + res = sexp_make_fixnum(tmp); +#if USE_BIGNUMS + } else { + sexp_gc_preserve1(ctx, res); + res = sexp_fixnum_to_bignum(ctx, i); + res = sexp_arithmetic_shift(ctx, res, count); + sexp_gc_release1(ctx); + } +#endif + } +#if USE_BIGNUMS + } else if (sexp_bignump(i)) { + len = sexp_bignum_hi(i); + if (c < 0) { + c = -c; + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + if (len < offset) { + res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1); + } else { + res = sexp_make_bignum(ctx, len - offset + 1); + for (j=len-offset, tmp=0; j>=0; j--) { + sexp_bignum_data(res)[j] + = (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp; + tmp = sexp_bignum_data(i)[j+offset] + << (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + } + } else { + offset = c / (sizeof(sexp_uint_t)*CHAR_BIT); + bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT); + res = sexp_make_bignum(ctx, len + offset + 1); + for (j=tmp=0; j> (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift); + } + sexp_bignum_data(res)[len+offset] = tmp; + } +#endif + } else { + res = sexp_type_exception(ctx, "arithmetic-shift: not an integer", i); + } + return sexp_bignum_normalize(res); +} + +/* bit-count and integer-length were adapted from: */ +/* http://graphics.stanford.edu/~seander/bithacks.html */ +static sexp_uint_t bit_count (sexp_uint_t i) { + i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3); + i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3) + + ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3)); + i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15; + return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255)) + >> (sizeof(i) - 1) * CHAR_BIT); +} + +static sexp sexp_bit_count (sexp ctx, sexp x) { + sexp res; + sexp_sint_t count, i; + if (sexp_fixnump(x)) { + i = sexp_unbox_fixnum(x); + res = sexp_make_fixnum(bit_count(i<0 ? ~i : i)); +#if USE_BIGNUMS + } else if (sexp_bignump(x)) { + for (i=count=0; i> 32)) + return integer_log2(tt) + 32; + else if ((tt = x >> 16)) + return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt]; + else + return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x]; +} + +static sexp sexp_integer_length (sexp ctx, sexp x) { + sexp_sint_t hi, tmp; + if (sexp_fixnump(x)) { + tmp = sexp_unbox_fixnum(x); + return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp)); +#if USE_BIGNUMS + } else if (sexp_bignump(x)) { + hi = sexp_bignum_hi(x); + return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi]) + + hi*sizeof(sexp_uint_t)); +#endif + } else { + return sexp_type_exception(ctx, "integer-length: not an integer", x); + } +} + +static sexp sexp_bit_set_p (sexp ctx, sexp i, sexp x) { + sexp_uint_t pos; + if (! sexp_fixnump(i)) + return sexp_type_exception(ctx, "bit-set?: not an integer", i); + if (sexp_fixnump(x)) { + return sexp_make_boolean(sexp_unbox_fixnum(x) & (1<0) && ! sexp_bignum_data(a)[i]) i--;