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

* Added uint-list->bytevector and sint-list->bytevector.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-17 03:36:28 -04:00
parent d62c01dfa7
commit 913bd590b6
3 changed files with 114 additions and 66 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.

178
src/ikarus.bytevectors.ss
View File

@ -6,7 +6,8 @@
bytevector-fill! bytevector-copy bytevector=? bytevector-fill! bytevector-copy bytevector=?
bytevector-uint-ref bytevector-sint-ref bytevector-uint-ref bytevector-sint-ref
bytevector-uint-set! bytevector-sint-set! bytevector-uint-set! bytevector-sint-set!
bytevector->uint-list bytevector->sint-list) bytevector->uint-list bytevector->sint-list
uint-list->bytevector sint-list->bytevector)
(import (import
(except (ikarus) (except (ikarus)
make-bytevector bytevector-length bytevector-s8-ref make-bytevector bytevector-length bytevector-s8-ref
@ -15,7 +16,8 @@
bytevector-fill! bytevector-copy bytevector=? bytevector-fill! bytevector-copy bytevector=?
bytevector-uint-ref bytevector-sint-ref bytevector-uint-ref bytevector-sint-ref
bytevector-uint-set! bytevector-sint-set! bytevector-uint-set! bytevector-sint-set!
bytevector->uint-list bytevector->sint-list) bytevector->uint-list bytevector->sint-list
uint-list->bytevector sint-list->bytevector)
(ikarus system $fx) (ikarus system $fx)
(ikarus system $bignums) (ikarus system $bignums)
(ikarus system $pairs) (ikarus system $pairs)
@ -393,64 +395,72 @@
(unless ($fx= i j) (unless ($fx= i j)
($bytevector-set! x i 0) ($bytevector-set! x i 0)
(bv-zero! x ($fxadd1 i) j))) (bv-zero! x ($fxadd1 i) j)))
(define (lbn-neg-copy! x xi n ni xj nj c) (define (make-lbn-neg-copy! who)
(cond (define (lbn-neg-copy! x xi n ni xj nj c)
[($fx= ni nj) (cond
(case ($fxsra c 7) [($fx= ni nj)
[(#x01) ;;; borrow is 0, last byte was negative (case ($fxsra c 7)
(bv-neg-zero! x xi xj)] [(#x01) ;;; borrow is 0, last byte was negative
[(#x00) ;;; borrow is 0, last byte was positive (bv-neg-zero! x xi xj)]
(if ($fx< xi xj) [(#x00) ;;; borrow is 0, last byte was positive
(bv-neg-zero! x xi xj) (if ($fx< xi xj)
(error 'bytevector-sint-set! "number ~s does not fit" n))] (bv-neg-zero! x xi xj)
[else (error 'lbn-neg-copy! "BUG: not handled ~s" c)])] (error who "number ~s does not fit" n))]
[else [else (error 'lbn-neg-copy! "BUG: not handled ~s" c)])]
(let ([c ($fx- ($fx+ 255 ($fxsra c 8)) ($bignum-byte-ref n ni))]) [else
(lbn-neg-copy! x ($fxadd1 xi) n ($fxadd1 ni) xj nj c) (let ([c ($fx- ($fx+ 255 ($fxsra c 8)) ($bignum-byte-ref n ni))])
($bytevector-set! x xi ($fxlogand c 255)))])) (lbn-neg-copy! x ($fxadd1 xi) n ($fxadd1 ni) xj nj c)
(define (bbn-neg-copy! x xi n ni xj nj c) ($bytevector-set! x xi ($fxlogand c 255)))]))
(cond lbn-neg-copy!)
[($fx= ni nj) (define (make-bbn-neg-copy! who)
(case ($fxsra c 7) (define (bbn-neg-copy! x xi n ni xj nj c)
[(#x01) ;;; borrow is 0, last byte was negative (cond
(bv-neg-zero! x xi xj)] [($fx= ni nj)
[(#x00) ;;; borrow is 0, last byte was positive (case ($fxsra c 7)
(if ($fx< xi xj) [(#x01) ;;; borrow is 0, last byte was negative
(bv-neg-zero! x xi xj) (bv-neg-zero! x xi xj)]
(error 'bytevector-sint-set! "number ~s does not fit" n))] [(#x00) ;;; borrow is 0, last byte was positive
[else (error 'bbn-neg-copy! "BUG: not handled ~s" c)])] (if ($fx< xi xj)
[else (bv-neg-zero! x xi xj)
(let ([c ($fx- ($fx+ 255 ($fxsra c 8)) ($bignum-byte-ref n ni))] (error who "number ~s does not fit" n))]
[xj ($fxsub1 xj)]) [else (error 'bbn-neg-copy! "BUG: not handled ~s" c)])]
(bbn-neg-copy! x xi n ($fxadd1 ni) xj nj c) [else
($bytevector-set! x xj ($fxlogand c 255)))])) (let ([c ($fx- ($fx+ 255 ($fxsra c 8)) ($bignum-byte-ref n ni))]
(define (lbn-pos-copy! x xi n ni nj xj c) [xj ($fxsub1 xj)])
(cond (bbn-neg-copy! x xi n ($fxadd1 ni) xj nj c)
[($fx= ni nj) ($bytevector-set! x xj ($fxlogand c 255)))]))
(cond bbn-neg-copy!)
[(or ($fx<= c 127) ($fx< xi xj)) (define (make-lbn-pos-copy! who)
;;; last byte was positive (define (lbn-pos-copy! x xi n ni nj xj c)
(bv-zero! x xi xj)] (cond
[else [($fx= ni nj)
(error 'bytevector-sint-set! "number ~s does not fit" n)])] (cond
[else [(or ($fx<= c 127) ($fx< xi xj))
(let ([c ($bignum-byte-ref n ni)]) ;;; last byte was positive
(lbn-pos-copy! x ($fxadd1 xi) n ($fxadd1 ni) nj xj c) (bv-zero! x xi xj)]
($bytevector-set! x xi ($fxlogand c 255)))])) [else
(define (bbn-pos-copy! x xi n ni nj xj c) (error who "number ~s does not fit" n)])]
(cond [else
[($fx= ni nj) (let ([c ($bignum-byte-ref n ni)])
(cond (lbn-pos-copy! x ($fxadd1 xi) n ($fxadd1 ni) nj xj c)
[(or ($fx<= c 127) ($fx< xi xj)) ($bytevector-set! x xi ($fxlogand c 255)))]))
;;; last byte was positive lbn-pos-copy!)
(bv-zero! x xi xj)] (define (make-bbn-pos-copy! who)
[else (define (bbn-pos-copy! x xi n ni nj xj c)
(error 'bytevector-sint-set! "number ~s does not fit" n)])] (cond
[else [($fx= ni nj)
(let ([c ($bignum-byte-ref n ni)] (cond
[xj ($fxsub1 xj)]) [(or ($fx<= c 127) ($fx< xi xj))
(bbn-pos-copy! x xi n ($fxadd1 ni) nj xj c) ;;; last byte was positive
($bytevector-set! x xj ($fxlogand c 255)))])) (bv-zero! x xi xj)]
[else
(error who "number ~s 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) (define (bv-neg-zero! x i j)
(unless ($fx= i j) (unless ($fx= i j)
($bytevector-set! x i 255) ($bytevector-set! x i 255)
@ -470,9 +480,8 @@
i-2)) i-2))
i-1)) i-1))
i)))) i))))
(define bytevector-uint-set! (define (make-bytevector-uint-set! who)
(lambda (x k n endianness size) (lambda (x k n endianness size)
(define who 'bytevector-uint-set!)
(unless (bytevector? x) (error who "~s is not a bytevector" x)) (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? k) ($fx>= k 0)) (error who "invalid index ~s" k))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" size)) (unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" size))
@ -507,10 +516,14 @@
[else (error who "number ~s does not fit" n)])) [else (error who "number ~s does not fit" n)]))
(error who "value ~s must be positive" n))] (error who "value ~s must be positive" n))]
[else (error who "invalid value argument ~s" n)])] [else (error who "invalid value argument ~s" n)])]
[else (error who "invalid endianness ~s" endianness)]))) [else (error who "invalid endianness ~s" endianness)])))
(define bytevector-sint-set! (define bytevector-uint-set! (make-bytevector-uint-set! 'bytevector-uint-set!))
(define (make-bytevector-sint-set! who)
(define bbn-neg-copy! (make-bbn-neg-copy! who))
(define bbn-pos-copy! (make-bbn-pos-copy! who))
(define lbn-neg-copy! (make-lbn-neg-copy! who))
(define lbn-pos-copy! (make-lbn-pos-copy! who))
(lambda (x k n endianness size) (lambda (x k n endianness size)
(define who 'bytevector-sint-set!)
(unless (bytevector? x) (error who "~s is not a bytevector" x)) (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? k) ($fx>= k 0)) (error who "invalid index ~s" k))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" size)) (unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" size))
@ -547,7 +560,40 @@
(bbn-neg-copy! x k n 0 size sz 256)] (bbn-neg-copy! x k n 0 size sz 256)]
[else (error who "number ~s does not fit" n)])))] [else (error who "number ~s does not fit" n)])))]
[else (error who "invalid value argument ~s" n)])] [else (error who "invalid value argument ~s" n)])]
[else (error who "invalid endianness ~s" endianness)])))) [else (error who "invalid endianness ~s" endianness)])))
(define bytevector-sint-set! (make-bytevector-sint-set! 'bytevector-sint-set!)))
(module (uint-list->bytevector sint-list->bytevector)
(define (make-xint-list->bytevector who bv-set!)
(define (race h t ls idx endianness size)
(if (pair? h)
(let ([h ($cdr h)] [a ($car h)])
(if (pair? h)
(if (not (eq? h t))
(let ([bv (race ($cdr h) ($cdr t) ls
($fx+ idx ($fx+ size size))
endianness size)])
(bv-set! bv idx a endianness size)
(bv-set! bv ($fx+ idx size) ($car h) endianness size)
bv)
(error who "circular list ~s" ls))
(if (null? h)
(let ([bv (make-bytevector ($fx+ idx size))])
(bv-set! bv idx a endianness size)
bv)
(error who "~s is not a proper list" ls))))
(if (null? h)
(make-bytevector idx)
(error who "~s is not a proper list" ls))))
(lambda (ls endianness size)
(race ls ls ls 0 endianness size)))
(define uint-list->bytevector
(make-xint-list->bytevector
'uint-list->bytevector bytevector-uint-set!))
(define sint-list->bytevector
(make-xint-list->bytevector
'sint-list->bytevector bytevector-sint-set!)))
) )

2
src/makefile.ss
View File

@ -289,6 +289,8 @@
[bytevector-sint-set! i] [bytevector-sint-set! i]
[bytevector->uint-list i] [bytevector->uint-list i]
[bytevector->sint-list i] [bytevector->sint-list i]
[uint-list->bytevector i]
[sint-list->bytevector i]
[for-each i r] [for-each i r]
[map i r] [map i r]