From 6caca77426412abd447a2c62c2cb621e7cbe4622 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 31 May 2020 23:24:51 +0900 Subject: [PATCH] adding (scheme bytevector) --- Makefile | 2 +- include/chibi/sexp.h | 1 + lib/scheme/bytevector-test.sld | 533 +++++++++++++++++++++++++++++++++ lib/scheme/bytevector.sld | 162 ++++++++++ lib/scheme/bytevector.stub | 331 ++++++++++++++++++++ sexp.c | 1 + 6 files changed, 1029 insertions(+), 1 deletion(-) create mode 100644 lib/scheme/bytevector-test.sld create mode 100644 lib/scheme/bytevector.sld create mode 100644 lib/scheme/bytevector.stub diff --git a/Makefile b/Makefile index 81908fc0..3b161fd1 100644 --- a/Makefile +++ b/Makefile @@ -41,7 +41,7 @@ COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \ lib/srfi/27/rand$(SO) lib/srfi/151/bit$(SO) \ lib/srfi/39/param$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \ lib/srfi/98/env$(SO) lib/srfi/144/math$(SO) lib/srfi/160/uvprims$(SO) \ - lib/scheme/time$(SO) + lib/scheme/bytevector$(SO) lib/scheme/time$(SO) BASE_INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h include/chibi/gc_heap.h diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index e9794b6d..76128436 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -1535,6 +1535,7 @@ enum sexp_context_globals { SEXP_G_THREADS_POLLFDS_ID, SEXP_G_ATOMIC_P, #endif + SEXP_G_ENDIANNESS, SEXP_G_NUM_GLOBALS }; diff --git a/lib/scheme/bytevector-test.sld b/lib/scheme/bytevector-test.sld new file mode 100644 index 00000000..464aebec --- /dev/null +++ b/lib/scheme/bytevector-test.sld @@ -0,0 +1,533 @@ + +;; adapted from guile bytevectors.test by Ludovic Courtès + +(define-library (scheme bytevector-test) + (import (except (scheme base) bytevector-copy!) + (scheme bytevector) + (scheme list) + (chibi test)) + (export run-tests) + (begin + (define (run-tests) + (test-begin "bytevector") + ;; (test 258 (bytevector-uint-ref #u8(0 1 2 0) 1 (endianness big) 2)) + ;; (test 513 (bytevector-uint-ref #u8(0 1 2 0) 1 (endianness little) 2)) + ;; (test -65281 + ;; (bytevector-sint-ref #u8(0 #xFF 1 0) 1 (endianness big) 2)) + ;; (test -65281 + ;; (bytevector-sint-ref #u8(0 1 #xFF 0) 1 (endianness little) 2)) + (test-begin "2.2 General Operations") + (test-assert "native-endianness" + (not (not (memq (native-endianness) '(big little))))) + + (test-assert "make-bytevector" + (and (bytevector? (make-bytevector 20)) + (bytevector? (make-bytevector 20 3)))) + + (test-assert "bytevector-length" + (= (bytevector-length (make-bytevector 20)) 20)) + + (test-assert "bytevector=?" + (and (bytevector=? (make-bytevector 20 7) + (make-bytevector 20 7)) + (not (bytevector=? (make-bytevector 20 7) + (make-bytevector 20 0))))) + + (test "bytevector-fill! with fill 255" + #u8(255 255 255 255) + (let ((bv (make-bytevector 4))) + (bytevector-fill! bv 255) + bv)) + + (test "bytevector-copy! overlapping" + #u8(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) + b)) + (test-end) + + (test-begin "2.3 Operations on Bytes and Octets") + + (test "bytevector-{u8,s8}-ref" + '(-127 129 -1 255) + (let ((b1 (make-bytevector 16 -127)) + (b2 (make-bytevector 16 255))) + (list (bytevector-s8-ref b1 0) + (bytevector-u8-ref b1 0) + (bytevector-s8-ref b2 0) + (bytevector-u8-ref b2 0)))) + + (test "bytevector-{u8,s8}-set!" + '(-126 130 -10 246) + (let ((b (make-bytevector 16 -127))) + (bytevector-s8-set! b 0 -126) + (bytevector-u8-set! b 1 246) + (list (bytevector-s8-ref b 0) + (bytevector-u8-ref b 0) + (bytevector-s8-ref b 1) + (bytevector-u8-ref b 1)))) + + (test-assert "bytevector->u8-list" + (let ((lst '(1 2 3 128 150 255))) + (equal? lst + (bytevector->u8-list + (let ((b (make-bytevector 6))) + (for-each (lambda (i v) + (bytevector-u8-set! b i v)) + (iota 6) + lst) + b))))) + + (test-assert "u8-list->bytevector" + (let ((lst '(1 2 3 128 150 255))) + (equal? lst + (bytevector->u8-list (u8-list->bytevector lst))))) + + (test-error "u8-list->bytevector [invalid argument type]" + (u8-list->bytevector 'not-a-list)) + + (test-error "u8-list->bytevector [circular list]" + (u8-list->bytevector (circular-list 1 2 3))) + + (test "bytevector-uint-{ref,set!} [small]" + #x3412 + (let ((b (make-bytevector 15))) + (bytevector-uint-set! b 0 #x1234 (endianness little) 2) + (bytevector-uint-ref b 0 (endianness big) 2))) + + (test "bytevector-uint-set! [large]" + '(253 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 255) + (let ((b (make-bytevector 16))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) (endianness little) 16) + (bytevector->u8-list b))) + + (test "bytevector-uint-{ref,set!} [large]" + #xfffffffffffffffffffffffffffffffd + (let ((b (make-bytevector 120))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) + (endianness little) 16) + (bytevector-uint-ref b 0 (endianness little) 16))) + + (test "bytevector-sint-ref big [small]" + -16 + (let ((b (u8-list->bytevector '(#xff #xf0 #xff)))) + (bytevector-sint-ref b 0 (endianness big) 2))) + + (test "bytevector-sint-ref little [small]" + -16 + (let ((b (u8-list->bytevector '(#xff #xf0 #xff)))) + (bytevector-sint-ref b 1 (endianness little) 2))) + + (test "bytevector-sint-ref [large]" + -3 + (let ((b (make-bytevector 50))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) (endianness little) 16) + (bytevector-sint-ref b 0 (endianness little) 16))) + + (test "bytevector-sint-set! [small]" + '(#xff #xf0 #xff) + (let ((b (make-bytevector 3))) + (bytevector-sint-set! b 0 -16 (endianness big) 2) + (bytevector-sint-set! b 1 -16 (endianness little) 2) + (bytevector->u8-list b))) + + (test-assert "equal?" + (let ((bv1 (u8-list->bytevector (iota 123))) + (bv2 (u8-list->bytevector (iota 123)))) + (equal? bv1 bv2))) + (test-end) + + (test-begin "2.4 Operations on Integers of Arbitrary Size") + + (test '(513 -253 513 513) + (bytevector->sint-list #u8(1 2 3 255 1 2 1 2) (endianness little) 2)) + + (test "bytevector->uint-list" + '(513 65283 513 513) + (let ((b (u8-list->bytevector '(2 1 255 3 2 1 2 1)))) + (bytevector->uint-list b (endianness big) 2))) + + (test "bytevector->uint-list [empty]" + '() + (let ((b (make-bytevector 0))) + (bytevector->uint-list b (endianness big) 2))) + + (test-error "bytevector->sint-list [out-of-range]" + (bytevector->sint-list (make-bytevector 6) (endianness little) -1)) + + (test-error "bytevector->uint-list [out-of-range]" + (bytevector->uint-list (make-bytevector 6) (endianness little) 0)) + + (test-error "bytevector->uint-list [word size doesn't divide length]" + (bytevector->uint-list (make-bytevector 6) (endianness little) 4)) + + (test-assert "{sint,uint}-list->bytevector" + (let ((b1 (sint-list->bytevector '(513 -253 513 513) + (endianness little) 2)) + (b2 (uint-list->bytevector '(513 65283 513 513) + (endianness little) 2)) + (b3 (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) + (and (bytevector=? b1 b2) + (bytevector=? b2 b3)))) + + (test-assert "sint-list->bytevector [limits]" + (bytevector=? (sint-list->bytevector '(-32768 32767) + (endianness big) 2) + (let ((bv (make-bytevector 4))) + (bytevector-u8-set! bv 0 #x80) + (bytevector-u8-set! bv 1 #x00) + (bytevector-u8-set! bv 2 #x7f) + (bytevector-u8-set! bv 3 #xff) + bv))) + + (test-error "sint-list->bytevector [invalid argument type]" + (sint-list->bytevector 'not-a-list (endianness big) 2)) + + (test-error "uint-list->bytevector [invalid argument type]" + (uint-list->bytevector 'not-a-list (endianness big) 2)) + + (test-error "sint-list->bytevector [circular list]" + (sint-list->bytevector (circular-list 1 2 3) (endianness big) + 2)) + + (test-error "uint-list->bytevector [circular list]" + (uint-list->bytevector (circular-list 1 2 3) (endianness big) + 2)) + + (test-error "sint-list->bytevector [out-of-range]" + (sint-list->bytevector (list 0 0 (expt 2 16)) (endianness big) + 2)) + + (test-error "uint-list->bytevector [out-of-range]" + (uint-list->bytevector '(0 -1) (endianness big) 2)) + (test-end) + + (test-begin "2.5 Operations on 16-Bit Integers") + + (let ((b #u8(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253))) + (test #xfdff (bytevector-u16-ref b 14 (endianness little))) + (test #xfffd (bytevector-u16-ref b 14 (endianness big)))) + + (let ((b #u8(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253))) + (test -513 (bytevector-s16-ref b 14 (endianness little))) + (test -3 (bytevector-s16-ref b 14 (endianness big)))) + + (let ((b (u8-list->bytevector '(#xff #xf0 #xff)))) + (test -16 (bytevector-s16-ref b 1 (endianness little)))) + + (test-assert "bytevector-{u16,s16}-ref" + (let ((b (make-bytevector 2))) + (bytevector-u16-set! b 0 44444 (endianness little)) + (and (equal? (bytevector-u16-ref b 0 (endianness little)) + 44444) + (equal? (bytevector-s16-ref b 0 (endianness little)) + (- 44444 65536))))) + + (test-assert "bytevector-native-{u16,s16}-{ref,set!}" + (let ((b (make-bytevector 2))) + (bytevector-u16-native-set! b 0 44444) + (and (equal? (bytevector-u16-native-ref b 0) + 44444) + (equal? (bytevector-s16-native-ref b 0) + (- 44444 65536))))) + + (test-assert "bytevector-s16-{ref,set!} [unaligned]" + (let ((b (make-bytevector 3))) + (bytevector-s16-set! b 1 -77 (endianness little)) + (equal? (bytevector-s16-ref b 1 (endianness little)) + -77))) + (test-end) + + (test-begin "2.6 Operations on 32-bit Integers") + + (test-assert "bytevector-u32-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-u32-ref b 12 (endianness little)) + #xfdffffff) + (equal? (bytevector-u32-ref b 12 (endianness big)) + #xfffffffd)))) + + (test-assert "bytevector-s32-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-s32-ref b 12 (endianness little)) + -33554433) + (equal? (bytevector-s32-ref b 12 (endianness big)) + -3)))) + + (test-assert "bytevector-{u32,s32}-ref" + (let ((b (make-bytevector 4))) + (bytevector-u32-set! b 0 2222222222 (endianness little)) + (and (equal? (bytevector-u32-ref b 0 (endianness little)) + 2222222222) + (equal? (bytevector-s32-ref b 0 (endianness little)) + (- 2222222222 (expt 2 32)))))) + + (test-assert "bytevector-{u32,s32}-native-{ref,set!}" + (let ((b (make-bytevector 4))) + (bytevector-u32-native-set! b 0 2222222222) + (and (equal? (bytevector-u32-native-ref b 0) + 2222222222) + (equal? (bytevector-s32-native-ref b 0) + (- 2222222222 (expt 2 32)))))) + (test-end) + + (test-begin "2.7 Operations on 64-bit Integers") + + (test-assert "bytevector-u64-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-u64-ref b 8 (endianness little)) + #xfdffffffffffffff) + (equal? (bytevector-u64-ref b 8 (endianness big)) + #xfffffffffffffffd)))) + + (test-assert "bytevector-s64-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-s64-ref b 8 (endianness little)) + -144115188075855873) + (equal? (bytevector-s64-ref b 8 (endianness big)) + -3)))) + + (test-assert "bytevector-{u64,s64}-ref" + (let ((b (make-bytevector 8)) + (big 9333333333333333333)) + (bytevector-u64-set! b 0 big (endianness little)) + (and (equal? (bytevector-u64-ref b 0 (endianness little)) + big) + (equal? (bytevector-s64-ref b 0 (endianness little)) + (- big (expt 2 64)))))) + + (test-assert "bytevector-{u64,s64}-native-{ref,set!}" + (let ((b (make-bytevector 8)) + (big 9333333333333333333)) + (bytevector-u64-native-set! b 0 big) + (and (equal? (bytevector-u64-native-ref b 0) + big) + (equal? (bytevector-s64-native-ref b 0) + (- big (expt 2 64)))))) + + (test-assert "ref/set! with zero" + (let ((b (make-bytevector 8))) + (bytevector-s64-set! b 0 -1 (endianness big)) + (bytevector-u64-set! b 0 0 (endianness big)) + (= 0 (bytevector-u64-ref b 0 (endianness big))))) + + (test-end) + + (test-begin "2.8 Operations on IEEE-754 Representations") + + (test-assert "single, little endian" + (let ((b (make-bytevector 4))) + (bytevector-ieee-single-set! b 0 1.0 (endianness little)) + (equal? #u8(0 0 128 63) b))) + + (test-assert "single, big endian" + (let ((b (make-bytevector 4))) + (bytevector-ieee-single-set! b 0 1.0 (endianness big)) + (equal? #u8(63 128 0 0) b))) + + (test-assert "bytevector-ieee-single-native-{ref,set!}" + (let ((b (make-bytevector 4)) + (number 3.00)) + (bytevector-ieee-single-native-set! b 0 number) + (equal? (bytevector-ieee-single-native-ref b 0) + number))) + + (test-assert "bytevector-ieee-single-{ref,set!}" + (let ((b (make-bytevector 8)) + (number 3.14)) + (bytevector-ieee-single-set! b 0 number (endianness little)) + (bytevector-ieee-single-set! b 4 number (endianness big)) + (equal? (bytevector-ieee-single-ref b 0 (endianness little)) + (bytevector-ieee-single-ref b 4 (endianness big))))) + + (test-assert "bytevector-ieee-single-{ref,set!} [unaligned]" + (let ((b (make-bytevector 9)) + (number 3.14)) + (bytevector-ieee-single-set! b 1 number (endianness little)) + (bytevector-ieee-single-set! b 5 number (endianness big)) + (equal? (bytevector-ieee-single-ref b 1 (endianness little)) + (bytevector-ieee-single-ref b 5 (endianness big))))) + + (test-assert "double, little endian" + (let ((b (make-bytevector 8))) + (bytevector-ieee-double-set! b 0 1.0 (endianness little)) + (equal? #u8(0 0 0 0 0 0 240 63) b))) + + (test-assert "double, big endian" + (let ((b (make-bytevector 8))) + (bytevector-ieee-double-set! b 0 1.0 (endianness big)) + (equal? #u8(63 240 0 0 0 0 0 0) b))) + + (test-assert "bytevector-ieee-double-native-{ref,set!}" + (let ((b (make-bytevector 8)) + (number 3.14)) + (bytevector-ieee-double-native-set! b 0 number) + (equal? (bytevector-ieee-double-native-ref b 0) + number))) + + (test-assert "bytevector-ieee-double-{ref,set!}" + (let ((b (make-bytevector 16)) + (number 3.14)) + (bytevector-ieee-double-set! b 0 number (endianness little)) + (bytevector-ieee-double-set! b 8 number (endianness big)) + (equal? (bytevector-ieee-double-ref b 0 (endianness little)) + (bytevector-ieee-double-ref b 8 (endianness big))))) + (test-end) + + + (test-begin "2.9 Operations on Strings") + + (test-assert "string->utf8" + (let* ((str "hello, world") + (utf8 (string->utf8 str))) + (and (bytevector? utf8) + (= (bytevector-length utf8) + (string-length str)) + (equal? (string->list str) + (map integer->char (bytevector->u8-list utf8)))))) + + (test-assert "string->utf8 [latin-1]" + (let* ((str "hé, ça va bien ?") + (utf8 (string->utf8 str))) + (and (bytevector? utf8) + (= (bytevector-length utf8) + (+ 2 (string-length str)))))) + + (test-assert "string->utf16" + (let* ((str "hello, world") + (utf16 (string->utf16 str))) + (and (bytevector? utf16) + (= (bytevector-length utf16) + (* 2 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 + (endianness big) 2)))))) + + (test-assert "string->utf16 [little]" + (let* ((str "hello, world") + (utf16 (string->utf16 str (endianness little)))) + (and (bytevector? utf16) + (= (bytevector-length utf16) + (* 2 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 + (endianness little) 2)))))) + + + (test-assert "string->utf32" + (let* ((str "hello, world") + (utf32 (string->utf32 str))) + (and (bytevector? utf32) + (= (bytevector-length utf32) + (* 4 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 + (endianness big) 4)))))) + + (test-assert "string->utf32 [Greek]" + (let* ((str "Ἄνεμοι") + (utf32 (string->utf32 str))) + (and (bytevector? utf32) + (equal? (bytevector->uint-list utf32 (endianness big) 4) + '(#x1f0c #x3bd #x3b5 #x3bc #x3bf #x3b9))))) + + (test-assert "string->utf32 [little]" + (let* ((str "hello, world") + (utf32 (string->utf32 str (endianness little)))) + (and (bytevector? utf32) + (= (bytevector-length utf32) + (* 4 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 + (endianness little) 4)))))) + + (test-assert "utf8->string" + (let* ((utf8 (u8-list->bytevector (map char->integer + (string->list "hello, world")))) + (str (utf8->string utf8))) + (and (string? str) + (= (string-length str) + (bytevector-length utf8)) + (equal? (string->list str) + (map integer->char (bytevector->u8-list utf8)))))) + + (test-assert "utf8->string [latin-1]" + (let* ((utf8 (string->utf8 "hé, ça va bien ?")) + (str (utf8->string utf8))) + (and (string? str) + (= (string-length str) + (- (bytevector-length utf8) 2))))) + + (test "utf8->string [replacement character]" + '(104 105 65533) + (map char->integer + (string->list (utf8->string #u8(104 105 239 191 189))))) + + (test-assert "utf16->string" + (let* ((utf16 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness big) 2)) + (str (utf16->string utf16))) + (and (string? str) + (= (* 2 (string-length str)) + (bytevector-length utf16)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 (endianness big) + 2)))))) + + (test-assert "utf16->string [little]" + (let* ((utf16 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness little) 2)) + (str (utf16->string utf16 (endianness little)))) + (and (string? str) + (= (* 2 (string-length str)) + (bytevector-length utf16)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 (endianness little) + 2)))))) + (test-assert "utf32->string" + (let* ((utf32 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness big) 4)) + (str (utf32->string utf32))) + (and (string? str) + (= (* 4 (string-length str)) + (bytevector-length utf32)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 (endianness big) + 4)))))) + + (test-assert "utf32->string [little]" + (let* ((utf32 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness little) 4)) + (str (utf32->string utf32 (endianness little)))) + (and (string? str) + (= (* 4 (string-length str)) + (bytevector-length utf32)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 (endianness little) + 4)))))) + (test-end) + + (test-end)))) diff --git a/lib/scheme/bytevector.sld b/lib/scheme/bytevector.sld new file mode 100644 index 00000000..aae00890 --- /dev/null +++ b/lib/scheme/bytevector.sld @@ -0,0 +1,162 @@ + +(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)))) + )) diff --git a/lib/scheme/bytevector.stub b/lib/scheme/bytevector.stub new file mode 100644 index 00000000..88c6acb7 --- /dev/null +++ b/lib/scheme/bytevector.stub @@ -0,0 +1,331 @@ + +(c-include "stdint.h") + +(define-c-int-type int8_t) +(define-c-int-type int16_t) +(define-c-int-type int32_t) +(define-c-int-type int64_t) +(define-c-int-type uint16_t) +(define-c-int-type uint32_t) +(define-c-int-type uint64_t) + +(c-declare + " +static int16_t sexp_swap_s16(int16_t n) { + return (n << 8) | ((n >> 8) & 0xFF); +} +static uint16_t sexp_swap_u16(uint16_t n) { + return (n >> 8) | ((n & 0xFF) << 8); +} +static int32_t sexp_swap_s32(int32_t n) { + n = ((n << 8) & 0xFF00FF00) | ((n >> 8) & 0xFF00FF); + return (n << 16) | ((n >> 16) & 0xFFFF); +} +static uint32_t sexp_swap_u32(uint32_t n) { + return ((n>>24)&0xff) | ((n<<8)&0xff0000) | + ((n>>8)&0xff00) | ((n<<24)&0xff000000); +} +static int64_t sexp_swap_s64(int64_t n) { + n = ((n << 8) & 0xFF00FF00FF00FF00ULL) | ((n >> 8) & 0x00FF00FF00FF00FFULL); + n = ((n << 16) & 0xFFFF0000FFFF0000ULL) | ((n >> 16) & 0x0000FFFF0000FFFFULL); + return (n << 32) | ((n >> 32) & 0xFFFFFFFFULL); +} +static uint64_t sexp_swap_u64(uint64_t n) { + n = ((n << 8) & 0xFF00FF00FF00FF00ULL) | ((n >> 8) & 0x00FF00FF00FF00FFULL); + n = ((n << 16) & 0xFFFF0000FFFF0000ULL ) | ((n >> 16) & 0x0000FFFF0000FFFFULL); + return (n << 32) | (n >> 32); +} +static float sexp_swap_float(const float x) { + float y; + const uint32_t* xs = (const uint32_t*) &x; + uint32_t* ys = (uint32_t*) &y; + *ys = sexp_swap_u32(*xs); + return y; +} +static double sexp_swap_double(const double x) { + double y; + const uint64_t* xs = (const uint64_t*) &x; + uint64_t* ys = (uint64_t*) &y; + *ys = sexp_swap_u64(*xs); + return y; +} + +sexp_sint_t decode_utf8(unsigned char* p, int ch_len) { + if (ch_len <= 1) + return *p; + else if (ch_len == 2) + return ((p[0]&0x3F)<<6) + (p[1]&0x3F); + else if (ch_len == 3) + return ((p[0]&0x1F)<<12) + ((p[1]&0x3F)<<6) + (p[2]&0x3F); + else + return ((p[0]&0x0F)<<18) + ((p[1]&0x3F)<<12) + ((p[2]&0x3F)<<6) + (p[3]&0x3F); +} + +sexp str2utf16(sexp ctx, char* s, int len, sexp endianness) { + unsigned char *p = (unsigned char*) s, *q; + uint16_t *utf16, hi, lo; + sexp_sint_t utf16_len, ch_len, ch, i; + sexp res; + q = p + len; + for (utf16_len=0; p> 10) + ((ch) >> 10)); + lo = (0xDC00 + ((ch) & 0x3FF)); + (*utf16++) = hi; + (*utf16++) = lo; + } else { + (*utf16++) = (uint16_t)ch; + } + p += ch_len; + } + if (endianness != sexp_global(ctx, SEXP_G_ENDIANNESS)) { + utf16 = (uint16_t*)sexp_bytes_data(res); + for (i=0; i>18)); *p++ = (0x80 + ((c>>12)&0x3F)); + *p++ = (0x80 + ((c>>6)&0x3F)); *p = (0x80 + (c&0x3F)); break; + case 3: *p++ = (0xE0 + ((c)>>12)); *p++ = (0x80 + ((c>>6)&0x3F)); + *p = (0x80 + (c&0x3F)); break; + case 2: *p++ = (0xC0 + ((c)>>6)); *p = (0x80 + (c&0x3F)); break; + default: *p = c; break; + } +} + +sexp utf16_2_str(sexp ctx, char* bv, int len, sexp endianness, int endianness_mandatory) { + int swap = endianness != sexp_global(ctx, SEXP_G_ENDIANNESS); + uint16_t ch, ch2; + sexp_sint_t i, ch_len, utf8_len=0, start=0; + sexp res; + unsigned char* dst; + if (!endianness_mandatory && len>1) { + ch = *(uint16_t*)(bv); + if (ch == 0xFFFE) { + swap = 1; + start = 2; + } else if (ch == 0xFEFF) { + start = 2; + } + } + for (i=start; i+13) { + ch = *(uint32_t*)(bv); + if (ch == 0xFFFE0000) { + swap = 1; + start = 4; + } else if (ch == 0xFEFF) { + start = 4; + } + } + for (i=start; i+3utf16 "str2utf16") + ((value ctx sexp) string (value (string-size arg1) int) (default (native-endianness) sexp))) + +(define-c sexp (%string->utf32 "str2utf32") + ((value ctx sexp) string (value (string-size arg1) int) (value (string-length arg1) int) (default (native-endianness) sexp))) + +(define-c sexp (%utf16->string "utf16_2_str") + ((value ctx sexp) bytevector (value (bytevector-length arg1) int) sexp (default SEXP_FALSE boolean))) + +(define-c sexp (%utf32->string "utf32_2_str") + ((value ctx sexp) bytevector (value (bytevector-length arg1) int) sexp (default SEXP_FALSE boolean))) diff --git a/sexp.c b/sexp.c index c4510b3a..09be1aae 100644 --- a/sexp.c +++ b/sexp.c @@ -567,6 +567,7 @@ void sexp_init_context_globals (sexp ctx) { sexp_global(ctx, SEXP_G_FEATURES) = SEXP_NULL; sexp_push(ctx, sexp_global(ctx, SEXP_G_FEATURES), SEXP_FALSE); sexp_car(sexp_global(ctx, SEXP_G_FEATURES)) = sexp_intern(ctx, (*(unsigned char*) &endianess_check) ? "little-endian" : "big-endian", -1); + sexp_global(ctx, SEXP_G_ENDIANNESS) = sexp_intern(ctx, (*(unsigned char*) &endianess_check) ? "little" : "big", -1); sexp_gc_preserve1(ctx, feature); for (features=sexp_initial_features; *features; features++) { feature = sexp_intern(ctx, *features, -1);