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

Reimplemented bytevector-uint-set! and bytevector-sint-set! to make 

the implementation simpler and more correct (previous one was
incorrect).
This commit is contained in:
Abdulaziz Ghuloum 2008-01-28 15:45:42 -05:00
parent a43177d399
commit 6bfe82ca9b
3 changed files with 69 additions and 207 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

262
scheme/ikarus.bytevectors.ss
View File

@ -732,212 +732,74 @@
'() sref-big 'bytevector->sint-list)] '() sref-big 'bytevector->sint-list)]
[else (die who "invalid endianness" endianness)])))) [else (die who "invalid endianness" endianness)]))))
(module (bytevector-uint-set! bytevector-sint-set!)
(define (lufx-set! x k1 n k2 who no) (define (bytevector-uint-set! bv i0 n endianness size)
(cond (define who 'bytevector-uint-set!)
[($fx= k1 k2) (unless (bytevector? bv)
(unless ($fxzero? n) (die who "not a bytevector" bv))
(die who "number does not fit" no))] (unless (or (fixnum? n) (bignum? n))
[else (die who "not an exact number" n))
(lufx-set! x ($fxadd1 k1) ($fxsra n 8) k2 who no) (unless (>= n 0)
($bytevector-set! x k1 ($fxlogand n 255))])) (die who "number must be positive" n))
(define (lsfx-set! x k1 n k2 who no) (let ([bvsize ($bytevector-length bv)])
(cond (unless (and (fixnum? i0)
[($fx= k1 k2) ($fx>= i0 0)
(unless ($fx= n -1) ;;; BUG: does not catch all errors ($fx< i0 bvsize))
(die who "number does not fit" no))] (die who "invalid index" i0))
[else (unless (and (fixnum? size)
(lsfx-set! x ($fxadd1 k1) ($fxsra n 8) k2 who no) ($fx>= size 0)
($bytevector-set! x k1 ($fxlogand n 255))])) ($fx<= i0 ($fx- bvsize size)))
(define (bufx-set! x k1 n k2 who no) (die who "invalid size" size)))
(cond (let ([nsize (bitwise-length n)])
[($fx= k1 k2) (when (< (* size 8) nsize)
(unless ($fxzero? n) (die who "number does not fit" n)))
(die who "number does not fit" no))]
[else
(let ([k2 ($fxsub1 k2)])
(bufx-set! x k1 ($fxsra n 8) k2 who no)
($bytevector-set! x k2 ($fxlogand n 255)))]))
(define (bsfx-set! x k1 n k2 who no)
(cond
[($fx= k1 k2)
(unless ($fx= n -1)
(die who "number does not fit" no))]
[else
(let ([k2 ($fxsub1 k2)])
(bsfx-set! x k1 ($fxsra n 8) k2 who no)
($bytevector-set! x k2 ($fxlogand n 255)))]))
(define (lbn-copy! x k n i j)
(unless ($fx= i j)
($bytevector-set! x k ($bignum-byte-ref n i))
(lbn-copy! x ($fxadd1 k) n ($fxadd1 i) j)))
(define (bbn-copy! x k n i j)
(unless ($fx= i j)
(let ([k ($fxsub1 k)])
($bytevector-set! x k ($bignum-byte-ref n i))
(bbn-copy! x k n ($fxadd1 i) j))))
(define (bv-zero! x i j)
(unless ($fx= i j)
($bytevector-set! x i 0)
(bv-zero! x ($fxadd1 i) j)))
(define (make-lbn-neg-copy! who)
(define (lbn-neg-copy! x xi n ni xj nj c)
(cond
[($fx= ni nj)
(case ($fxsra c 7)
[(#x01) ;;; borrow is 0, last byte was negative
(bv-neg-zero! x xi xj)]
[(#x00) ;;; borrow is 0, last byte was positive
(if ($fx< xi xj)
(bv-neg-zero! x xi xj)
(die who "number does not fit" n))]
[else (die 'lbn-neg-copy! "BUG: not handled" c)])]
[else
(let ([c ($fx- ($fx+ 255 ($fxsra c 8)) ($bignum-byte-ref n ni))])
(lbn-neg-copy! x ($fxadd1 xi) n ($fxadd1 ni) xj nj c)
($bytevector-set! x xi ($fxlogand c 255)))]))
lbn-neg-copy!)
(define (make-bbn-neg-copy! who)
(define (bbn-neg-copy! x xi n ni xj nj c)
(cond
[($fx= ni nj)
(case ($fxsra c 7)
[(#x01) ;;; borrow is 0, last byte was negative
(bv-neg-zero! x xi xj)]
[(#x00) ;;; borrow is 0, last byte was positive
(if ($fx< xi xj)
(bv-neg-zero! x xi xj)
(die who "number does not fit" n))]
[else (die 'bbn-neg-copy! "BUG: not handled" c)])]
[else
(let ([c ($fx- ($fx+ 255 ($fxsra c 8)) ($bignum-byte-ref n ni))]
[xj ($fxsub1 xj)])
(bbn-neg-copy! x xi n ($fxadd1 ni) xj nj c)
($bytevector-set! x xj ($fxlogand c 255)))]))
bbn-neg-copy!)
(define (make-lbn-pos-copy! who)
(define (lbn-pos-copy! x xi n ni nj xj c)
(cond
[($fx= ni nj)
(cond
[(or ($fx<= c 127) ($fx< xi xj))
;;; last byte was positive
(bv-zero! x xi xj)]
[else
(die who "number does not fit" n)])]
[else
(let ([c ($bignum-byte-ref n ni)])
(lbn-pos-copy! x ($fxadd1 xi) n ($fxadd1 ni) nj xj c)
($bytevector-set! x xi ($fxlogand c 255)))]))
lbn-pos-copy!)
(define (make-bbn-pos-copy! who)
(define (bbn-pos-copy! x xi n ni nj xj c)
(cond
[($fx= ni nj)
(cond
[(or ($fx<= c 127) ($fx< xi xj))
;;; last byte was positive
(bv-zero! x xi xj)]
[else
(die who "number does not fit" n)])]
[else
(let ([c ($bignum-byte-ref n ni)]
[xj ($fxsub1 xj)])
(bbn-pos-copy! x xi n ($fxadd1 ni) nj xj c)
($bytevector-set! x xj ($fxlogand c 255)))]))
bbn-pos-copy!)
(define (bv-neg-zero! x i j)
(unless ($fx= i j)
($bytevector-set! x i 255)
(bv-neg-zero! x ($fxadd1 i) j)))
(define (bignum-bytes n)
(let f ([n n] [i ($bignum-size n)])
(let ([i-1 ($fxsub1 i)])
(if ($fxzero? ($bignum-byte-ref n i-1))
(f n i-1)
i))))
(define (make-bytevector-uint-set! who)
(lambda (x k n endianness size)
(unless (bytevector? x) (die who "not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (die who "invalid index" k))
(unless (and (fixnum? size) ($fx>= size 1)) (die who "invalid size" size))
(case endianness (case endianness
[(little) [(little)
(cond (let f ([bv bv] [i0 i0] [i1 (fx+ i0 size)] [n n])
[(fixnum? n) (lufx-set! x k n ($fx+ k size) who n)] (unless ($fx= i0 i1)
[(bignum? n) ($bytevector-set! bv i0 (bitwise-and n 255))
(if ($bignum-positive? n) (f bv ($fx+ i0 1) i1 (sra n 8))))]
(let ([sz (bignum-bytes n)])
(cond
[($fx= sz size)
(lbn-copy! x k n 0 sz)]
[($fx< sz size)
(lbn-copy! x k n 0 sz)
(bv-zero! x ($fx+ k sz) ($fx+ k size))]
[else (die who "number does not fit" n)]))
(die who "value must be positive" n))]
[else (die who "invalid value argument" n)])]
[(big) [(big)
(cond (let f ([bv bv] [i0 i0] [i1 (fx+ i0 size)] [n n])
[(fixnum? n) (bufx-set! x k n ($fx+ k size) who n)] (unless ($fx= i0 i1)
[(bignum? n) (let ([i1 ($fx- i1 1)])
(if ($bignum-positive? n) ($bytevector-set! bv i1 (bitwise-and n 255))
(let ([sz (bignum-bytes n)]) (f bv i0 i1 (sra n 8)))))]
(cond [else (die who "invalid endianness" endianness)]))
[($fx<= sz size)
(bbn-copy! x ($fx+ k size) n 0 sz)]
[($fx< sz size) (define (bytevector-sint-set! bv i0 n endianness size)
(bbn-copy! x ($fx+ k size) n 0 sz) (define who 'bytevector-sint-set!)
(bv-zero! x k ($fx+ k ($fx- size sz)))] (unless (bytevector? bv)
[else (die who "number does not fit" n)])) (die who "not a bytevector" bv))
(die who "value must be positive" n))] (unless (or (fixnum? n) (bignum? n))
[else (die who "invalid value argument" n)])] (die who "not an exact number" n))
[else (die who "invalid endianness" endianness)]))) (let ([bvsize ($bytevector-length bv)])
(define bytevector-uint-set! (make-bytevector-uint-set! 'bytevector-uint-set!)) (unless (and (fixnum? i0)
(define (make-bytevector-sint-set! who) ($fx>= i0 0)
(define bbn-neg-copy! (make-bbn-neg-copy! who)) ($fx< i0 bvsize))
(define bbn-pos-copy! (make-bbn-pos-copy! who)) (die who "invalid index" i0))
(define lbn-neg-copy! (make-lbn-neg-copy! who)) (unless (and (fixnum? size)
(define lbn-pos-copy! (make-lbn-pos-copy! who)) ($fx>= size 0)
(lambda (x k n endianness size) ($fx<= i0 ($fx- bvsize size)))
(unless (bytevector? x) (die who "not a bytevector" x)) (die who "invalid size" size)))
(unless (and (fixnum? k) ($fx>= k 0)) (die who "invalid index" k)) (let ([nsize (+ (bitwise-length n) 1)])
(unless (and (fixnum? size) ($fx>= size 1)) (die who "invalid size" size)) (when (< (* size 8) nsize)
(die who "number does not fit" n)))
(case endianness (case endianness
[(little) [(little)
(cond (let f ([bv bv] [i0 i0] [i1 (fx+ i0 size)] [n n])
[(fixnum? n) (lsfx-set! x k n ($fx+ k size) who n)] (unless ($fx= i0 i1)
[(bignum? n) ($bytevector-set! bv i0 (bitwise-and n 255))
(if ($bignum-positive? n) (f bv ($fx+ i0 1) i1 (sra n 8))))]
(let ([sz (bignum-bytes n)])
(cond
[($fx<= sz size)
(lbn-pos-copy! x k n 0 size sz 255)]
[else (die who "number does not fit" n)]))
(let ([sz (bignum-bytes n)])
(cond
[($fx<= sz size)
(lbn-neg-copy! x k n 0 size sz 256)]
[else (die who "number does not fit" n)])))]
[else (die who "invalid value argument" n)])]
[(big) [(big)
(cond (let f ([bv bv] [i0 i0] [i1 (fx+ i0 size)] [n n])
[(fixnum? n) (bsfx-set! x k n ($fx+ k size) who n)] (unless ($fx= i0 i1)
[(bignum? n) (let ([i1 ($fx- i1 1)])
(if ($bignum-positive? n) ($bytevector-set! bv i1 (bitwise-and n 255))
(let ([sz (bignum-bytes n)]) (f bv i0 i1 (sra n 8)))))]
(cond [else (die who "invalid endianness" endianness)]))
[($fx<= sz size)
(bbn-pos-copy! x k n 0 size sz 255)]
[else (die who "number does not fit" n)]))
(let ([sz (bignum-bytes n)])
(cond
[($fx<= sz size)
(bbn-neg-copy! x k n 0 size sz 256)]
[else (die who "number does not fit" n)])))]
[else (die who "invalid value argument" n)])]
[else (die who "invalid endianness" endianness)])))
(define bytevector-sint-set! (make-bytevector-sint-set! 'bytevector-sint-set!)))
(module (uint-list->bytevector sint-list->bytevector) (module (uint-list->bytevector sint-list->bytevector)
(define (make-xint-list->bytevector who bv-set!) (define (make-xint-list->bytevector who bv-set!)

2
scheme/last-revision
View File

@ -1 +1 @@
1365 1367