199 lines
7.7 KiB
Scheme
199 lines
7.7 KiB
Scheme
|
|
(library (ikarus bytevectors)
|
|
(export make-bytevector bytevector-length bytevector-s8-ref
|
|
bytevector-u8-ref bytevector-u8-set! bytevector-s8-set!
|
|
bytevector-copy! u8-list->bytevector bytevector->u8-list
|
|
bytevector-fill! bytevector-copy bytevector=?)
|
|
(import
|
|
(except (ikarus)
|
|
make-bytevector bytevector-length bytevector-s8-ref
|
|
bytevector-u8-ref bytevector-u8-set! bytevector-s8-set!
|
|
bytevector-copy! u8-list->bytevector bytevector->u8-list
|
|
bytevector-fill! bytevector-copy bytevector=?)
|
|
(ikarus system $fx)
|
|
(ikarus system $pairs)
|
|
(ikarus system $bytevectors))
|
|
|
|
(define ($bytevector-fill x i j fill)
|
|
(cond
|
|
[($fx= i j) x]
|
|
[else
|
|
($bytevector-set! x i fill)
|
|
($bytevector-fill x ($fxadd1 i) j fill)]))
|
|
|
|
(define make-bytevector
|
|
(case-lambda
|
|
[(k)
|
|
(if (and (fixnum? k) ($fx>= k 0))
|
|
($make-bytevector k)
|
|
(error 'make-bytevector "~s is not a valid size" k))]
|
|
[(k fill)
|
|
(if (and (fixnum? fill) ($fx<= -128 fill) ($fx<= fill 255))
|
|
($bytevector-fill (make-bytevector k) 0 k fill)
|
|
(error 'make-bytevector "~s is not a valid fill" fill))]))
|
|
|
|
(define bytevector-fill!
|
|
(lambda (x fill)
|
|
(unless (bytevector? x)
|
|
(error 'bytevector-fill! "~s is not a bytevector" x))
|
|
(unless (and (fixnum? fill) ($fx<= -128 fill) ($fx<= fill 255))
|
|
(error 'bytevector-fill! "~s is not a valid fill" fill))
|
|
($bytevector-fill x 0 ($bytevector-length x) fill)))
|
|
|
|
|
|
(define bytevector-length
|
|
(lambda (x)
|
|
(if (bytevector? x)
|
|
($bytevector-length x)
|
|
(error 'bytevector-length "~s is not a bytevector" x))))
|
|
|
|
(define bytevector-s8-ref
|
|
(lambda (x i)
|
|
(if (bytevector? x)
|
|
(if (and (fixnum? i) ($fx<= 0 i) ($fx< i ($bytevector-length x)))
|
|
($bytevector-s8-ref x i)
|
|
(error 'bytevector-s8-ref "invalid index ~s for ~s" i x))
|
|
(error 'bytevector-s8-ref "~s is not a bytevector" x))))
|
|
|
|
(define bytevector-u8-ref
|
|
(lambda (x i)
|
|
(if (bytevector? x)
|
|
(if (and (fixnum? i) ($fx<= 0 i) ($fx< i ($bytevector-length x)))
|
|
($bytevector-u8-ref x i)
|
|
(error 'bytevector-u8-ref "invalid index ~s for ~s" i x))
|
|
(error 'bytevector-u8-ref "~s is not a bytevector" x))))
|
|
|
|
|
|
(define bytevector-s8-set!
|
|
(lambda (x i v)
|
|
(if (bytevector? x)
|
|
(if (and (fixnum? i) ($fx<= 0 i) ($fx< i ($bytevector-length x)))
|
|
(if (and (fixnum? v) ($fx<= -128 v) ($fx<= v 127))
|
|
($bytevector-set! x i v)
|
|
(error 'bytevector-s8-set! "~s is not a byte" v))
|
|
(error 'bytevector-s8-set! "invalid index ~s for ~s" i x))
|
|
(error 'bytevector-s8-set! "~s is not a bytevector" x))))
|
|
|
|
(define bytevector-u8-set!
|
|
(lambda (x i v)
|
|
(if (bytevector? x)
|
|
(if (and (fixnum? i) ($fx<= 0 i) ($fx< i ($bytevector-length x)))
|
|
(if (and (fixnum? v) ($fx<= 0 v) ($fx<= v 255))
|
|
($bytevector-set! x i v)
|
|
(error 'bytevector-u8-set! "~s is not an octet" v))
|
|
(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)
|
|
(unless (bytevector? src)
|
|
(error 'bytevector-copy "~s is not a bytevector" src))
|
|
(let ([n ($bytevector-length src)])
|
|
(let f ([src src] [dst ($make-bytevector n)] [i 0] [n n])
|
|
(cond
|
|
[($fx= i n) dst]
|
|
[else
|
|
($bytevector-set! dst i ($bytevector-u8-ref src i))
|
|
(f src dst ($fxadd1 i) n)])))))
|
|
|
|
(define bytevector=?
|
|
(lambda (x y)
|
|
(unless (bytevector? x)
|
|
(error 'bytevector=? "~s is not a bytevector" x))
|
|
(unless (bytevector? y)
|
|
(error 'bytevector=? "~s is not a bytevector" y))
|
|
(let ([n ($bytevector-length x)])
|
|
(and ($fx= n ($bytevector-length y))
|
|
(let f ([x x] [y y] [i 0] [n n])
|
|
(or ($fx= i n)
|
|
(and ($fx= ($bytevector-u8-ref x i)
|
|
($bytevector-u8-ref y i))
|
|
(f x y ($fxadd1 i) n))))))))
|
|
|
|
(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)))])))
|
|
|
|
|
|
|
|
)
|
|
|
|
|