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

* Added bitwise-and

This commit is contained in:
Abdulaziz Ghuloum 2007-11-08 19:18:37 -05:00
parent cd3d4ab77a
commit 6e6c9c9c1b
5 changed files with 37 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.orig
View File

Binary file not shown.

13
scheme/ikarus.bytevectors.ss
View File

@ -56,6 +56,7 @@
bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
bytevector-ieee-double-ref bytevector-ieee-double-set!
native-endianness)
;(only (rnrs) bitwise-and)
(ikarus system $fx)
(ikarus system $bignums)
(ikarus system $pairs)
@ -334,14 +335,14 @@
(let ([b (sra n 16)])
($bytevector-set! x i ($fxsra b 8))
($bytevector-set! x ($fx+ i 1) b))
(let ([b (logand n #xFFFF)])
(let ([b (bitwise-and n #xFFFF)])
($bytevector-set! x ($fx+ i 2) ($fxsra b 8))
($bytevector-set! x ($fx+ i 3) b))]
[(little)
(let ([b (sra n 16)])
($bytevector-set! x ($fx+ i 3) ($fxsra b 8))
($bytevector-set! x ($fx+ i 2) b))
(let ([b (logand n #xFFFF)])
(let ([b (bitwise-and n #xFFFF)])
($bytevector-set! x ($fx+ i 1) ($fxsra b 8))
($bytevector-set! x i b))]
[else (error 'bytevector-u32-ref "invalid endianness" end)])
@ -365,7 +366,7 @@
(let ([b (sra n 16)])
($bytevector-set! x i ($fxsra b 8))
($bytevector-set! x ($fx+ i 1) b))
(let ([b (logand n #xFFFF)])
(let ([b (bitwise-and n #xFFFF)])
($bytevector-set! x ($fx+ i 2) ($fxsra b 8))
($bytevector-set! x ($fx+ i 3) b)))
(error 'bytevector-u32-native-set! "invalid index" i))
@ -389,7 +390,7 @@
(let ([b (sra n 16)])
($bytevector-set! x i ($fxsra b 8))
($bytevector-set! x ($fx+ i 1) b))
(let ([b (logand n #xFFFF)])
(let ([b (bitwise-and n #xFFFF)])
($bytevector-set! x ($fx+ i 2) ($fxsra b 8))
($bytevector-set! x ($fx+ i 3) b)))
(error 'bytevector-s32-native-set! "invalid index" i))
@ -412,14 +413,14 @@
(let ([b (sra n 16)])
($bytevector-set! x i ($fxsra b 8))
($bytevector-set! x ($fx+ i 1) b))
(let ([b (logand n #xFFFF)])
(let ([b (bitwise-and n #xFFFF)])
($bytevector-set! x ($fx+ i 2) ($fxsra b 8))
($bytevector-set! x ($fx+ i 3) b))]
[(little)
(let ([b (sra n 16)])
($bytevector-set! x ($fx+ i 3) ($fxsra b 8))
($bytevector-set! x ($fx+ i 2) b))
(let ([b (logand n #xFFFF)])
(let ([b (bitwise-and n #xFFFF)])
($bytevector-set! x ($fx+ i 1) ($fxsra b 8))
($bytevector-set! x i b))]
[else (error 'bytevector-s32-ref "invalid endianness" end)])

34
scheme/ikarus.numerics.ss
View File

@ -325,7 +325,7 @@
(library (ikarus generic-arithmetic)
(export + - * / zero? = < <= > >= add1 sub1 quotient remainder
modulo even? odd? logand $two-bignums
modulo even? odd? logand bitwise-and
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
@ -345,7 +345,7 @@
(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
positive? negative? bitwise-and logand
string->number expt gcd lcm numerator denominator
exact->inexact inexact floor ceiling round log
exact-integer-sqrt min max abs
@ -354,13 +354,6 @@
sin cos tan asin acos atan sqrt truncate fltruncate
flround flmax random))
(define ($two-bignums)
(list 1234567890 -1234567890
12345678901234567890
-12345678901234567890
1234567890123456789012345678901234567890
-1234567890123456789012345678901234567890))
; (foreign-call "ikrt_fixnum_to_flonum" x))
(module (bignum->flonum)
; sbe f6 f5 f4 f3 f2 f1 f0
@ -625,7 +618,7 @@
(error '+ "not a number" y)])]
[else (error '+ "not a number" x)])))
(define binary-logand
(define binary-bitwise-and
(lambda (x y)
(cond
[(fixnum? x)
@ -634,7 +627,7 @@
[(bignum? y)
(foreign-call "ikrt_fxbnlogand" x y)]
[else
(error 'logand "not an exact integer" y)])]
(error 'bitwise-and "not an exact integer" y)])]
[(bignum? x)
(cond
[(fixnum? y)
@ -642,8 +635,8 @@
[(bignum? y)
(foreign-call "ikrt_bnbnlogand" x y)]
[else
(error 'logand "not an exact integer" y)])]
[else (error 'logand "not an exact integer" x)])))
(error 'bitwise-and "not an exact integer" y)])]
[else (error 'bitwise-and "not an exact integer" x)])))
(define binary-
@ -766,22 +759,25 @@
[(null? e*) ac]
[else (f (binary+ ac (car e*)) (cdr e*))]))]))
(define logand
(define bitwise-and
(case-lambda
[(x y) (binary-logand x y)]
[(x y z) (binary-logand (binary-logand x y) z)]
[(x y) (binary-bitwise-and x y)]
[(x y z) (binary-bitwise-and (binary-bitwise-and x y) z)]
[(a)
(cond
[(fixnum? a) a]
[(bignum? a) a]
[else (error 'logand "not a number" a)])]
[else (error 'bitwise-and "not a number" a)])]
[() -1]
[(a b c d . e*)
(let f ([ac (binary-logand (binary-logand (binary-logand a b) c) d)]
(let f ([ac (binary-bitwise-and
(binary-bitwise-and
(binary-bitwise-and a b) c) d)]
[e* e*])
(cond
[(null? e*) ac]
[else (f (binary-logand ac (car e*)) (cdr e*))]))]))
[else (f (binary-bitwise-and ac (car e*)) (cdr e*))]))]))
(define logand bitwise-and)
(define -
(case-lambda

3
scheme/makefile.ss
View File

@ -292,7 +292,6 @@
[sra i]
[sll i]
[fxlogand i]
[logand i]
[fxlogxor i]
[fxlogor i]
[fxlognot i]
@ -748,7 +747,7 @@
[bitwise-arithmetic-shift-left i r bw]
[bitwise-arithmetic-shift-right i r bw]
[bitwise-not r bw]
[bitwise-and r bw]
[bitwise-and i r bw]
[bitwise-ior r bw]
[bitwise-xor r bw]
[bitwise-bit-count r bw]

28
scheme/todo-r6rs.ss
View File

@ -255,20 +255,20 @@
[bitwise-arithmetic-shift C bw]
[bitwise-arithmetic-shift-left C bw]
[bitwise-arithmetic-shift-right C bw]
[bitwise-not D bw]
[bitwise-and D bw]
[bitwise-ior D bw]
[bitwise-xor D bw]
[bitwise-bit-count D bw]
[bitwise-bit-field D bw]
[bitwise-bit-set? D bw]
[bitwise-copy-bit D bw]
[bitwise-copy-bit-field D bw]
[bitwise-first-bit-set D bw]
[bitwise-if D bw]
[bitwise-length D bw]
[bitwise-reverse-bit-field D bw]
[bitwise-rotate-bit-field D bw]
[bitwise-not S bw]
[bitwise-and C bw]
[bitwise-ior S bw]
[bitwise-xor S bw]
[bitwise-bit-count S bw]
[bitwise-bit-field S bw]
[bitwise-bit-set? S bw]
[bitwise-copy-bit S bw]
[bitwise-copy-bit-field S bw]
[bitwise-first-bit-set S bw]
[bitwise-if S bw]
[bitwise-length S bw]
[bitwise-reverse-bit-field S bw]
[bitwise-rotate-bit-field S bw]
;;;
[fixnum? C fx]
[fixnum-width C fx]