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

* Added bytevector->u8-list, u8-list->bytevector, and 

bytevector-copy!.
This commit is contained in:
Abdulaziz Ghuloum 2007-05-15 14:27:31 -04:00
parent a809afd0fb
commit f630177d17
4 changed files with 95 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.

89
src/ikarus.bytevectors.ss
View File

@ -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)))])))
)

3
src/makefile.ss
View File

@ -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]

5
src/tests/bytevectors.ss
View File

@ -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))]
))