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

* Added bytevector-uint-set!

This commit is contained in:
Abdulaziz Ghuloum 2007-05-15 20:19:24 -04:00
parent 4062b00c29
commit 9488a0706f
4 changed files with 57 additions and 2 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.

38
src/ikarus.bytevectors.ss
View File

@ -5,6 +5,7 @@
bytevector-copy! u8-list->bytevector bytevector->u8-list
bytevector-fill! bytevector-copy bytevector=?
bytevector-uint-ref bytevector-sint-ref
bytevector-uint-set!
bytevector->uint-list bytevector->sint-list)
(import
(except (ikarus)
@ -13,6 +14,7 @@
bytevector-copy! u8-list->bytevector bytevector->u8-list
bytevector-fill! bytevector-copy bytevector=?
bytevector-uint-ref bytevector-sint-ref
bytevector-uint-set!
bytevector->uint-list bytevector->sint-list)
(ikarus system $fx)
(ikarus system $pairs)
@ -340,8 +342,40 @@
'() sref-little 'bytevector->sint-list)]
[(big) (bytevector->some-list x size ($bytevector-length x)
'() sref-big 'bytevector->sint-list)]
[else (error who "invalid endianness ~s" endianness)])))
)
[else (error who "invalid endianness ~s" endianness)]))))
(module (bytevector-uint-set!)
(define (little-uint-set! x k n size)
(cond
[($fx= size 0)
(unless (zero? n)
(error 'bytevector-uint-set! "value out of range"))]
[else
(let-values ([(q r) (quotient+remainder n 256)])
(little-uint-set! x ($fxadd1 k) q ($fxsub1 size))
($bytevector-set! x k r))]))
(define (big-uint-set! x k1 n k2)
(cond
[($fx= k1 k2)
(unless (zero? n)
(error 'bytevector-uint-set! "value out of range"))]
[else
(let-values ([(q r) (quotient+remainder n 256)])
(let ([k2 ($fxsub1 k2)])
(big-uint-set! x k1 q k2)
($bytevector-set! x k2 r)))]))
(define bytevector-uint-set!
(lambda (x k n endianness size)
(define who 'bytevector-uint-set!)
(unless (bytevector? x) (error who "~s is not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (error who "invalid index ~s" k))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" size))
(unless (or (fixnum? n) (bignum? n)) (error who "invalid value ~s" n))
(case endianness
[(little) (little-uint-set! x k n size)]
[(big) (big-uint-set! x k n ($fx+ k size))]
[else (error who "invalid endianness ~s" endianness)]))))

1
src/makefile.ss
View File

@ -285,6 +285,7 @@
[bytevector=? i]
[bytevector-uint-ref i]
[bytevector-sint-ref i]
[bytevector-uint-set! i]
[bytevector->uint-list i]
[bytevector->sint-list i]

20
src/tests/bytevectors.ss
View File

@ -85,6 +85,26 @@
[(lambda (x) (equal? x '(513 -253 513 513)))
(let ([b (u8-list->bytevector '(1 2 3 255 1 2 1 2))])
(bytevector->sint-list b 'little 2))]
[(lambda (x) (equal? x '(#xfffffffffffffffffffffffffffffffd
-3
(253 255 255 255 255 255 255 255
255 255 255 255 255 255 255 255))))
(let ([b (make-bytevector 16 -127)])
(bytevector-uint-set! b 0 (- (expt 2 128) 3) 'little 16)
(list
(bytevector-uint-ref b 0 'little 16)
(bytevector-sint-ref b 0 'little 16)
(bytevector->u8-list b)))]
[(lambda (x) (equal? x '(#xfffffffffffffffffffffffffffffffd
-3
(255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 253))))
(let ([b (make-bytevector 16 -127)])
(bytevector-uint-set! b 0 (- (expt 2 128) 3) 'big 16)
(list
(bytevector-uint-ref b 0 'big 16)
(bytevector-sint-ref b 0 'big 16)
(bytevector->u8-list b)))]
))