conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Added bitwise-arithmetic-shift, bitwise-arithmetic-shift-left, 

and bitwise-arithmetic-shift-right,
This commit is contained in:
Abdulaziz Ghuloum 2007-09-13 01:10:57 -04:00
parent 6b1860af65
commit 2f75448f03
4 changed files with 58 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

59
src/ikarus.numerics.ss
View File

@ -310,6 +310,7 @@
(library (ikarus generic-arithmetic)
(export + - * / zero? = < <= > >= add1 sub1 quotient remainder
modulo even? odd? logand $two-bignums
bitwise-arithmetic-shift-right bitwise-arithmetic-shift-left bitwise-arithmetic-shift
positive? negative? expt gcd lcm numerator denominator exact-integer-sqrt
quotient+remainder number->string string->number min max
abs truncate fltruncate sra sll
@ -327,6 +328,7 @@
(only (ikarus flonums) $flonum->exact $flzero? $flnegative?)
(except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient
remainder modulo even? odd? quotient+remainder number->string
bitwise-arithmetic-shift-right bitwise-arithmetic-shift-left bitwise-arithmetic-shift
positive? negative? logand $two-bignums
string->number expt gcd lcm numerator denominator
exact->inexact inexact floor ceiling round log
@ -2189,40 +2191,77 @@
(error 'random "~s is not a fixnum" n)))
(define (sra n m)
(define (shift-right-arithmetic n m who)
(unless (fixnum? m)
(error 'sra "shift amount ~s is not a fixnum"))
(error who "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)])]
[else (error who "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)]))
[else (error who "offset ~s must be non-negative" m)])]
[else (error who "~s is not an exact integer" n)]))
(define (sra n m)
(shift-right-arithmetic n m 'sra))
(define (sll n m)
(define (shift-left-logical n m who)
(unless (fixnum? m)
(error 'sll "shift amount ~s is not a fixnum"))
(error who "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)])]
[else (error who "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)]))
[else (error who "offset ~s must be non-negative" m)])]
[else (error who "~s is not an exact integer" n)]))
(define (sll n m)
(shift-left-logical n m 'sll))
(define (bitwise-arithmetic-shift-right n m)
(shift-right-arithmetic n m 'bitwise-arithmetic-shift-right))
(define (bitwise-arithmetic-shift-left n m)
(shift-left-logical n m 'bitwise-arithmetic-shift-left))
(define (bitwise-arithmetic-shift n m)
(define who 'bitwise-arithmetic-shift)
(unless (fixnum? m)
(error who "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
(let ([m^ (- m)])
(unless (fixnum? m^)
(error who "shift amount ~s is too big" m))
($fxsra n m^))])]
[(bignum? n)
(cond
[($fx> m 0)
(foreign-call "ikrt_bignum_shift_left" n m)]
[($fx= m 0) n]
[else
(let ([m^ (- m)])
(unless (fixnum? m^)
(error who "shift amount ~s is too big" m))
(foreign-call "ikrt_bignum_shift_right" n m^))])]
[else (error who "~s is not an exact integer" n)]))
)

6
src/makefile.ss
View File

@ -457,6 +457,12 @@
[fxlogxor i]
[fxlogor i]
[fxlognot i]
[bitwise-arithmetic-shift-right i]
[bitwise-arithmetic-shift-left i]
[bitwise-arithmetic-shift i]
[fl=? i rfl]
[fl<? i rfl]
[fl<=? i rfl]

6
src/todo-r6rs.ss
View File

@ -238,9 +238,9 @@
[else C ba ex]
;;;
[bitwise-and D bw]
[bitwise-arithmetic-shift D bw]
[bitwise-arithmetic-shift-left D bw]
[bitwise-arithmetic-shift-right D bw]
[bitwise-arithmetic-shift C bw]
[bitwise-arithmetic-shift-left C bw]
[bitwise-arithmetic-shift-right C bw]
[bitwise-bit-count D bw]
[bitwise-bit-field D bw]
[bitwise-bit-set? D bw]