mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
162 lines
7 KiB
Scheme
162 lines
7 KiB
Scheme
|
|
(define-library (scheme bytevector)
|
|
(import (rename (scheme base)
|
|
(bytevector-copy! %bytevector-copy!))
|
|
(scheme bitwise)
|
|
(only (chibi)
|
|
er-macro-transformer
|
|
strip-syntactic-closures))
|
|
(export
|
|
endianness native-endianness bytevector? make-bytevector
|
|
bytevector-length bytevector=? bytevector-fill! bytevector-copy!
|
|
bytevector-u8-ref bytevector-s8-ref
|
|
bytevector-u8-set! bytevector-s8-set!
|
|
bytevector->u8-list u8-list->bytevector
|
|
bytevector-uint-ref bytevector-sint-ref
|
|
bytevector-uint-set! bytevector-sint-set!
|
|
bytevector->uint-list uint-list->bytevector
|
|
bytevector->sint-list sint-list->bytevector
|
|
bytevector-u16-ref bytevector-s16-ref
|
|
bytevector-u16-set! bytevector-s16-set!
|
|
bytevector-u16-native-ref bytevector-s16-native-ref
|
|
bytevector-u16-native-set! bytevector-s16-native-set!
|
|
bytevector-u32-ref bytevector-s32-ref
|
|
bytevector-u32-set! bytevector-s32-set!
|
|
bytevector-u32-native-ref bytevector-s32-native-ref
|
|
bytevector-u32-native-set! bytevector-s32-native-set!
|
|
bytevector-u64-ref bytevector-s64-ref
|
|
bytevector-u64-set! bytevector-s64-set!
|
|
bytevector-u64-native-ref bytevector-s64-native-ref
|
|
bytevector-u64-native-set! bytevector-s64-native-set!
|
|
bytevector-ieee-single-native-ref
|
|
bytevector-ieee-single-ref
|
|
bytevector-ieee-double-native-ref
|
|
bytevector-ieee-double-ref
|
|
bytevector-ieee-single-native-set!
|
|
bytevector-ieee-single-set!
|
|
bytevector-ieee-double-native-set!
|
|
bytevector-ieee-double-set!
|
|
string->utf8
|
|
string->utf16
|
|
string->utf32
|
|
utf8->string
|
|
utf16->string
|
|
utf32->string
|
|
)
|
|
(cond-expand
|
|
(big-endian (begin (define (native-endianness) 'big)))
|
|
(else (begin (define (native-endianness) 'little))))
|
|
(begin
|
|
(define-syntax endianness
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(if (not (and (pair? (cdr expr))
|
|
(null? (cddr expr))
|
|
(memq (strip-syntactic-closures (cadr expr))
|
|
'(big little))))
|
|
(error "endianness must be 'big or 'little" expr))
|
|
`(,(rename 'quote) ,(cadr expr)))))
|
|
(define (bytevector=? a b)
|
|
(if (not (and (bytevector? a) (bytevector? b)))
|
|
(error "bytevector expected" a b))
|
|
(equal? a b))
|
|
(define (bytevector-fill! bv elt)
|
|
(do ((i (- (bytevector-length bv) 1) (- i 1)))
|
|
((< i 0))
|
|
(bytevector-u8-set! bv i elt)))
|
|
(define (bytevector-copy! from start to . o)
|
|
(let* ((at (if (pair? o) (car o) 0))
|
|
(len (if (and (pair? o) (pair? (cdr o)))
|
|
(cadr o)
|
|
(- (bytevector-length to) at)))
|
|
(end (+ start len)))
|
|
(%bytevector-copy! to at from start end)))
|
|
(define (bytevector->u8-list bv)
|
|
(do ((i (- (bytevector-length bv) 1) (- i 1))
|
|
(res '() (cons (bytevector-u8-ref bv i) res)))
|
|
((< i 0) res)))
|
|
(define (u8-list->bytevector ls)
|
|
(let* ((len (length ls))
|
|
(res (make-bytevector len)))
|
|
(do ((ls ls (cdr ls))
|
|
(i 0 (+ i 1)))
|
|
((null? ls) res)
|
|
(bytevector-u8-set! res i (car ls))))))
|
|
(include-shared "bytevector")
|
|
(begin
|
|
(define (string->utf16 str . o)
|
|
(%string->utf16 str (if (pair? o) (car o) (endianness big))))
|
|
(define (string->utf32 str . o)
|
|
(%string->utf32 str (if (pair? o) (car o) (endianness big))))
|
|
(define (utf16->string bv . o)
|
|
(let ((endianness (if (pair? o) (car o) (endianness big)))
|
|
(endianness-mandatory? (and (pair? o) (pair? (cdr o)) (cadr o))))
|
|
(%utf16->string bv endianness endianness-mandatory?)))
|
|
(define (utf32->string bv . o)
|
|
(let ((endianness (if (pair? o) (car o) (endianness big)))
|
|
(endianness-mandatory? (and (pair? o) (pair? (cdr o)) (cadr o))))
|
|
(%utf32->string bv endianness endianness-mandatory?)))
|
|
(define (bytevector-uint-ref bv k endianness size)
|
|
(unless (positive? size) (error "size must be positive" size))
|
|
(if (eq? endianness 'big)
|
|
(do ((i 0 (+ i 1))
|
|
(res 0 (+ (* res 256) (bytevector-u8-ref bv (+ k i)))))
|
|
((>= i size) res))
|
|
(do ((i (- size 1) (- i 1))
|
|
(res 0 (+ (* res 256) (bytevector-u8-ref bv (+ k i)))))
|
|
((< i 0) res))))
|
|
(define (bytevector-sint-ref bv k endianness size)
|
|
(unless (positive? size) (error "size must be positive" size))
|
|
(let ((n (bytevector-uint-ref bv k endianness size))
|
|
(mask (expt 2 (- (* 8 size) 1))))
|
|
(- (bitwise-and n (bitwise-not mask))
|
|
(bitwise-and n mask))))
|
|
(define (bytevector-uint-set! bv k n endianness size)
|
|
(unless (positive? size) (error "size must be positive" size))
|
|
(if (eq? endianness 'big)
|
|
(do ((i (- size 1) (- i 1))
|
|
(n n (arithmetic-shift n -8)))
|
|
((< i 0))
|
|
(bytevector-u8-set! bv (+ k i) (bitwise-and n #xFF)))
|
|
(do ((i 0 (+ i 1))
|
|
(n n (arithmetic-shift n -8)))
|
|
((>= i size))
|
|
(bytevector-u8-set! bv (+ k i) (bitwise-and n #xFF)))))
|
|
(define (bytevector-sint-set! bv k n endianness size)
|
|
(bytevector-uint-set! bv k (+ (expt 2 (* 8 size)) n) endianness size))
|
|
(define (bytevector->uint-list bv endianness size)
|
|
(unless (positive? size) (error "size must be positive" size))
|
|
(unless (zero? (modulo (bytevector-length bv) size))
|
|
(error "size must divide length" (bytevector-length bv) size))
|
|
(do ((i 0 (+ i size))
|
|
(res '() (cons (bytevector-uint-ref bv i endianness size) res)))
|
|
((> (+ i size) (bytevector-length bv)) (reverse res))))
|
|
(define (bytevector->sint-list bv endianness size)
|
|
(unless (positive? size) (error "size must be positive" size))
|
|
(unless (zero? (modulo (bytevector-length bv) size))
|
|
(error "size must divide length" (bytevector-length bv) size))
|
|
(do ((i 0 (+ i size))
|
|
(res '() (cons (bytevector-sint-ref bv i endianness size) res)))
|
|
((> (+ i size) (bytevector-length bv)) (reverse res))))
|
|
(define (uint-list->bytevector ls endianness size)
|
|
(unless (positive? size) (error "size must be positive" size))
|
|
(let ((res (make-bytevector (* (length ls) size) 0))
|
|
(limit (expt 2 (* size 8))))
|
|
(do ((ls ls (cdr ls))
|
|
(i 0 (+ i size)))
|
|
((null? ls) res)
|
|
(unless (<= 0 (car ls) limit)
|
|
(error "out of range" (car ls) limit))
|
|
(bytevector-uint-set! res i (car ls) endianness size))))
|
|
(define (sint-list->bytevector ls endianness size)
|
|
(unless (positive? size) (error "size must be positive" size))
|
|
(let* ((res (make-bytevector (* (length ls) size) 0))
|
|
(lo (- (expt 2 (- (* size 8) 1))))
|
|
(hi (- -1 lo)))
|
|
(do ((ls ls (cdr ls))
|
|
(i 0 (+ i size)))
|
|
((null? ls) res)
|
|
(unless (<= lo (car ls) hi)
|
|
(error "out of range" (car ls) lo hi))
|
|
(bytevector-sint-set! res i (car ls) endianness size))))
|
|
))
|