diff --git a/src/ikarus.boot b/src/ikarus.boot index 978cfb8..02ff10b 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.bytevectors.ss b/src/ikarus.bytevectors.ss index 3ea4612..df0380f 100644 --- a/src/ikarus.bytevectors.ss +++ b/src/ikarus.bytevectors.ss @@ -1,12 +1,15 @@ (library (ikarus bytevectors) (export make-bytevector bytevector-length bytevector-s8-ref - bytevector-u8-ref bytevector-u8-set! bytevector-s8-set!) + bytevector-u8-ref bytevector-u8-set! bytevector-s8-set! + bytevector-copy! u8-list->bytevector bytevector->u8-list) (import (except (ikarus) make-bytevector bytevector-length bytevector-s8-ref - bytevector-u8-ref bytevector-u8-set! bytevector-s8-set!) + bytevector-u8-ref bytevector-u8-set! bytevector-s8-set! + bytevector-copy! u8-list->bytevector bytevector->u8-list) (ikarus system $fx) + (ikarus system $pairs) (ikarus system $bytevectors)) (define ($bytevector-fill x i j fill) @@ -70,6 +73,88 @@ (error 'bytevector-u8-set! "invalid index ~s for ~s" i x)) (error 'bytevector-u8-set! "~s is not a bytevector" x)))) + (define bytevector->u8-list + (lambda (x) + (unless (bytevector? x) + (error 'bytevector->u8-list "~s is not a bytevector" x)) + (let f ([x x] [i ($bytevector-length x)] [ac '()]) + (cond + [($fx= i 0) ac] + [else + (let ([i ($fxsub1 i)]) + (f x i (cons ($bytevector-u8-ref x i) ac)))])))) + + (define u8-list->bytevector + (letrec ([race + (lambda (h t ls n) + (if (pair? h) + (let ([h ($cdr h)]) + (if (pair? h) + (if (not (eq? h t)) + (race ($cdr h) ($cdr t) ls ($fx+ n 2)) + (error 'u8-list->bytevector "circular list ~s" ls)) + (if (null? h) + ($fx+ n 1) + (error 'u8-list->bytevector "~s is not a proper list" ls)))) + (if (null? h) + n + (error 'u8-list->bytevector "~s is not a proper list" ls))))] + [fill + (lambda (s i ls) + (cond + [(null? ls) s] + [else + (let ([c ($car ls)]) + (unless (and (fixnum? c) ($fx<= 0 c) ($fx<= c 255)) + (error 'u8-list->bytevector "~s is not an octet" c)) + ($bytevector-set! s i c) + (fill s ($fxadd1 i) (cdr ls)))]))]) + (lambda (ls) + (let ([n (race ls ls ls 0)]) + (let ([s ($make-bytevector n)]) + (fill s 0 ls)))))) + + (define bytevector-copy! + (lambda (src src-start dst dst-start k) + (cond + [(or (not (fixnum? src-start)) ($fx< src-start 0)) + (error 'bytevector-copy! "~s is not a valid starting index" src-start)] + [(or (not (fixnum? dst-start)) ($fx< dst-start 0)) + (error 'bytevector-copy! "~s is not a valid starting index" dst-start)] + [(or (not (fixnum? k)) ($fx< k 0)) + (error 'bytevector-copy! "~s is not a valid length" k)] + [(not (bytevector? src)) + (error 'bytevector-copy! "~s is not a bytevector" src)] + [(not (bytevector? dst)) + (error 'bytevector-copy! "~s is not a bytevector" dst)] + [(let ([n ($fx+ src-start k)]) + (or ($fx< n 0) ($fx>= n ($bytevector-length src)))) + (error 'bytevector-copy! "~s+~s is out of range" src-start k)] + [(let ([n ($fx+ dst-start k)]) + (or ($fx< n 0) ($fx>= n ($bytevector-length dst)))) + (error 'bytevector-copy! "~s+~s is out of range" dst-start k)] + [(eq? src dst) + (cond + [($fx< dst-start src-start) + (let f ([src src] [si src-start] [di dst-start] [sj ($fx+ src-start k)]) + (unless ($fx= si sj) + ($bytevector-set! src di ($bytevector-u8-ref src si)) + (f src ($fxadd1 si) ($fxadd1 di) sj)))] + [($fx< src-start dst-start) + (let f ([src src] [si ($fx+ src-start k)] [di ($fx+ dst-start k)] [sj src-start]) + (unless ($fx= si sj) + (let ([si ($fxsub1 si)] [di ($fxsub1 di)]) + ($bytevector-set! src di ($bytevector-u8-ref src si)) + (f src si di sj))))] + [else (void)])] + [else + (let f ([src src] [si src-start] [dst dst] [di dst-start] [sj ($fx+ src-start k)]) + (unless ($fx= si sj) + ($bytevector-set! dst di ($bytevector-u8-ref src si)) + (f src ($fxadd1 si) dst ($fxadd1 di) sj)))]))) + + + ) diff --git a/src/makefile.ss b/src/makefile.ss index c3bf15b..a0eb64c 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -277,6 +277,9 @@ [bytevector-u8-ref i] [bytevector-s8-set! i] [bytevector-u8-set! i] + [bytevector->u8-list i] + [u8-list->bytevector i] + [bytevector-copy! i] [for-each i r] [map i r] diff --git a/src/tests/bytevectors.ss b/src/tests/bytevectors.ss index 06e41f6..5033b73 100644 --- a/src/tests/bytevectors.ss +++ b/src/tests/bytevectors.ss @@ -35,6 +35,11 @@ (bytevector-s8-ref b 1) (bytevector-u8-ref b 1)))] + [(lambda (x) (equal? x '(1 2 3 1 2 3 4 8))) + (let ([b (u8-list->bytevector '(1 2 3 4 5 6 7 8))]) + (bytevector-copy! b 0 b 3 4) + (bytevector->u8-list b))] + ))