diff --git a/BUGS b/BUGS index 26af0e5..f2e372d 100644 --- a/BUGS +++ b/BUGS @@ -2,6 +2,8 @@ BUG: * (exact->inexact (/ (expt 2 3000) (- (expt 2 3000) 1))) should return 1.0, not +nan.0. +* fxsra does not work for large numbers + * pretty-print goes into infinite loop on cyclic data * set! on global names is not working. * Ensure immutable exports diff --git a/bin/ikarus b/bin/ikarus index fb01e5e..b11721d 100755 Binary files a/bin/ikarus and b/bin/ikarus differ diff --git a/bin/ikarus-numerics.c b/bin/ikarus-numerics.c index 9a53d94..2bdbf0e 100644 --- a/bin/ikarus-numerics.c +++ b/bin/ikarus-numerics.c @@ -1024,6 +1024,18 @@ bits_compliment(unsigned int* src, unsigned int* dst, int n){ } } +static void +bits_compliment_with_carry(unsigned int* src, unsigned int* dst, int + n, int carry){ + int i; + for(i=0; i> m; + int i; + for(i=1; i> m; + } + dst[n-1] = carry; +} + + + + +ikp +ikrt_bignum_shift_right(ikp x, ikp y, ikpcb* pcb){ + int m = unfix(y); + ikp fst = ref(x, -vector_tag); + int n = ((unsigned int) fst) >> bignum_length_shift; + int whole_limb_shift = m >> 5; /* FIXME: 5 are the bits in 32-bit num */ + int bit_shift = m & 31; + int new_limb_count = n - whole_limb_shift; + if(bignum_sign_mask & (unsigned int) fst){ + if(new_limb_count <= 0){ + return fix(-1); + } + if(bit_shift == 0){ + ikp r = ik_alloc(pcb, align(disp_bignum_data + new_limb_count * wordsize)); + bits_compliment_with_carry( + (unsigned int*)(x+off_bignum_data+whole_limb_shift*wordsize), + (unsigned int*)(r+disp_bignum_data), + new_limb_count, + bits_carry((unsigned int*)(x+off_bignum_data), whole_limb_shift)); + bits_compliment( + (unsigned int*)(r+disp_bignum_data), + (unsigned int*)(r+disp_bignum_data), + new_limb_count); + return normalize_bignum(new_limb_count, 1 << bignum_sign_shift, r); + } else { + ikp r = ik_alloc(pcb, align(disp_bignum_data + new_limb_count * wordsize)); + bits_compliment_with_carry( + (unsigned int*)(x+off_bignum_data+whole_limb_shift*wordsize), + (unsigned int*)(r+disp_bignum_data), + new_limb_count, + bits_carry((unsigned int*)(x+off_bignum_data), whole_limb_shift)); + copy_bits_shifting_right( + (unsigned int*)(r+disp_bignum_data), + (unsigned int*)(r+disp_bignum_data), + new_limb_count, + bit_shift); + *((unsigned int*)(r+disp_bignum_data+(new_limb_count-1)*wordsize)) + |= (-1 << (32 - bit_shift)); + bits_compliment( + (unsigned int*)(r+disp_bignum_data), + (unsigned int*)(r+disp_bignum_data), + new_limb_count); + return normalize_bignum(new_limb_count, 1 << bignum_sign_shift, r); + fprintf(stderr, "not yet for negative bignum_shift\n"); + exit(-1); + } + } else { + if(new_limb_count <= 0){ + return 0; + } + if(bit_shift == 0){ + ikp r = ik_alloc(pcb, align(disp_bignum_data + new_limb_count * wordsize)); + memcpy(r+disp_bignum_data, + x+off_bignum_data+whole_limb_shift*wordsize, + new_limb_count * wordsize); + return normalize_bignum(new_limb_count, 0, r); + } else { + ikp r = ik_alloc(pcb, align(disp_bignum_data + new_limb_count * wordsize)); + copy_bits_shifting_right( + (unsigned int*)(x+off_bignum_data+whole_limb_shift*wordsize), + (unsigned int*)(r+disp_bignum_data), + new_limb_count, + bit_shift); + return normalize_bignum(new_limb_count, 0, r); + } + } +} + + +ikp +ikrt_fixnum_shift_left(ikp x, ikp y, ikpcb* pcb){ + fprintf(stderr, "fxshiftleft\n"); + exit(-1); +} + +ikp +ikrt_bignum_shift_left(ikp x, ikp y, ikpcb* pcb){ + fprintf(stderr, "bnshiftleft\n"); + exit(-1); +} + + #if 0 From TFM: void diff --git a/src/ikarus.boot b/src/ikarus.boot index 42e844b..54618c4 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.numerics.ss b/src/ikarus.numerics.ss index d684e97..96be0a0 100644 --- a/src/ikarus.numerics.ss +++ b/src/ikarus.numerics.ss @@ -312,7 +312,7 @@ modulo even? odd? logand $two-bignums positive? negative? expt gcd lcm numerator denominator exact-integer-sqrt quotient+remainder number->string string->number min max - abs truncate fltruncate + abs truncate fltruncate sra sll exact->inexact inexact floor ceiling round log fl=? fl? fl>=? fl+ fl- fl* fl/ flsqrt flmin flzero? flnegative? sin cos tan asin acos atan sqrt @@ -332,7 +332,7 @@ exact->inexact inexact floor ceiling round log exact-integer-sqrt min max abs fl=? fl? fl>=? fl+ fl- fl* fl/ flsqrt flmin - flzero? flnegative? + flzero? flnegative? sra sll sin cos tan asin acos atan sqrt truncate fltruncate flround flmax random)) @@ -546,8 +546,6 @@ (if (= r 0) (inexact q) (+ q (f r d))))))) - ;(binary/ (exact->inexact ($ratnum-n x)) - ; (exact->inexact ($ratnum-d x)))) (define binary+ (lambda (x y) @@ -2189,6 +2187,43 @@ 0 (error 'random "incorrect argument ~s" n))) (error 'random "~s is not a fixnum" n))) + + + (define (sra n m) + (unless (fixnum? m) + (error 'sra "shift amount ~s is not a fixnum")) + (cond + [(fixnum? n) + (cond + [($fx>= m 0) ($fxsra n m)] + [else (error 'sra "offset ~s must be non-negative" m)])] + [(bignum? n) + (cond + [($fx> m 0) + (foreign-call "ikrt_bignum_shift_right" n m)] + [($fx= m 0) n] + [else (error 'sra "offset ~s must be non-negative" m)])] + [else (error 'sra "~s is not an exact integer" n)])) + + + (define (sll n m) + (unless (fixnum? m) + (error 'sll "shift amount ~s is not a fixnum")) + (cond + [(fixnum? n) + (cond + [($fx> m 0) + (foreign-call "ikrt_fixnum_shift_left" n m)] + [($fx= m 0) n] + [else (error 'sll "offset ~s must be non-negative" m)])] + [(bignum? n) + (cond + [($fx> m 0) + (foreign-call "ikrt_bignum_shift_left" n m)] + [($fx= m 0) n] + [else (error 'sll "offset ~s must be non-negative" m)])] + [else (error 'sll "~s is not an exact integer" n)])) + ) diff --git a/src/makefile.ss b/src/makefile.ss index 763b9aa..2db7545 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -450,6 +450,8 @@ [fxmodulo i] [fxsll i] [fxsra i] + [sra i] + [sll i] [fxlogand i] [logand i] [fxlogxor i]