adding (scheme bytevector)

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

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
 };
 

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

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))))
+    ))

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<q; ++utf16_len) {
+    ch_len = sexp_utf8_initial_byte_count(*p);
+    if (ch_len == 4) ++utf16_len;   /* surrogate */
+    p += ch_len;
+  }
+  res = sexp_make_bytes(ctx, sexp_make_fixnum(utf16_len*2), SEXP_VOID);
+  if (!sexp_bytesp(res)) return res;
+  utf16 = (uint16_t*)sexp_bytes_data(res);
+  for (p=(unsigned char*)s; p<q; ) {
+    ch_len = sexp_utf8_initial_byte_count(*p);
+    ch = decode_utf8(p, ch_len);
+    if (ch_len == 4) {
+      hi = (0xD800 - (0x10000 >> 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<utf16_len; ++i) {
+      utf16[i] = sexp_swap_u16(utf16[i]);
+    }
+  }
+  return res;
+}
+
+sexp str2utf32(sexp ctx, char* s, int len, int utf32_len, sexp endianness) {
+  unsigned char *p = (unsigned char*) s, *q;
+  uint32_t *utf32;
+  sexp_sint_t ch_len, i;
+  sexp res;
+  q = p + len;
+  res = sexp_make_bytes(ctx, sexp_make_fixnum(utf32_len*4), SEXP_VOID);
+  if (!sexp_bytesp(res)) return res;
+  utf32 = (uint32_t*)sexp_bytes_data(res);
+  while (p<q) {
+    ch_len = sexp_utf8_initial_byte_count(*p);
+    (*utf32++) = (uint32_t)decode_utf8(p, ch_len);
+    p += ch_len;
+  }
+  if (endianness != sexp_global(ctx, SEXP_G_ENDIANNESS)) {
+    utf32 = (uint32_t*)sexp_bytes_data(res);
+    for (i=0; i<utf32_len; ++i) {
+      utf32[i] = sexp_swap_u32(utf32[i]);
+    }
+  }
+  return res;
+}
+
+static int utf8_char_byte_count(int c) {
+  if (c < 0x80) return 1;
+  if (c < 0x800) return 2;
+  if (c < 0x10000) return 3;
+  return 4;
+}
+
+static void utf8_encode_char(unsigned char* p, int len, int c) {
+  switch (len) {
+  case 4:  *p++ = (0xF0 + ((c)>>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+1<len; i+=2) {
+    ch = swap ? sexp_swap_u16(*((uint16_t*)(bv+i))) : *((uint16_t*)(bv+i));
+    if (0xd800 <= ch && ch <= 0xdbff && i+3<len) {
+      ch2 = swap ? sexp_swap_u16(*((uint16_t*)(bv+i+2))) : *((uint16_t*)(bv+i+2));
+      if (0xdc00 <= ch2 && ch2 <= 0xdfff) {
+        ch = 0x10000 + (((ch - 0xd800) << 10) | (ch2 - 0xdc00));
+        i += 2;
+      }
+    }
+    utf8_len += utf8_char_byte_count(ch);
+  }
+  res = sexp_make_string(ctx, sexp_make_fixnum(utf8_len), SEXP_VOID);
+  if (!(res && sexp_stringp(res))) return res;
+  dst = (unsigned char*) sexp_string_data(res);
+  for (i=start; i+1<len; i+=2) {
+    ch = swap ? sexp_swap_u16(*((uint16_t*)(bv+i))) : *((uint16_t*)(bv+i));
+    if (0xd800 <= ch && ch <= 0xdbff && i+3<len) {
+      ch2 = swap ? sexp_swap_u16(*((uint16_t*)(bv+i+2))) : *((uint16_t*)(bv+i+2));
+      if (0xdc00 <= ch2 && ch2 <= 0xdfff) {
+        ch = 0x10000 + (((ch - 0xd800) << 10) | (ch2 - 0xdc00));
+        i += 2;
+      }
+    }
+    ch_len = utf8_char_byte_count(ch);
+    utf8_encode_char(dst, ch_len, ch);
+    dst += ch_len;
+  }
+  return res;
+}
+
+sexp utf32_2_str(sexp ctx, char* bv, int len, sexp endianness, int endianness_mandatory) {
+  int swap = endianness != sexp_global(ctx, SEXP_G_ENDIANNESS);
+  uint32_t ch;
+  sexp_sint_t i, ch_len, utf8_len=0, start=0;
+  sexp res;
+  unsigned char* dst;
+  if (!endianness_mandatory && len>3) {
+    ch = *(uint32_t*)(bv);
+    if (ch == 0xFFFE0000) {
+      swap = 1;
+      start = 4;
+    } else if (ch == 0xFEFF) {
+      start = 4;
+    }
+  }
+  for (i=start; i+3<len; i+=4) {
+    ch = swap ? sexp_swap_u32(*((uint32_t*)(bv+i))) : *((uint32_t*)(bv+i));
+    utf8_len += utf8_char_byte_count(ch);
+  }
+  res = sexp_make_string(ctx, sexp_make_fixnum(utf8_len), SEXP_VOID);
+  if (!(res && sexp_stringp(res))) return res;
+  dst = (unsigned char*) sexp_string_data(res);
+  for (i=start; i+3<len; i+=4) {
+    ch = swap ? sexp_swap_u32(*((uint32_t*)(bv+i))) : *((uint32_t*)(bv+i));
+    ch_len = utf8_char_byte_count(ch);
+    utf8_encode_char(dst, ch_len, ch);
+    dst += ch_len;
+  }
+  return res;
+}
+")
+
+(define-c int8_t bytevector-s8-ref (bytevector int)
+  (inline "((int8_t*)arg0)[arg1]"))
+(define-c void bytevector-s8-set! (bytevector int int8_t)
+  (assert (< -1 arg1 (bytevector-length arg0)))
+  (inline "((int8_t*)arg0)[arg1] = arg2"))
+
+(define-c int16_t bytevector-s16-native-ref (bytevector int)
+  (inline "*((int16_t*)(arg0+arg1))"))
+(define-c void bytevector-s16-native-set! (bytevector int int16_t)
+  (assert (< -1 arg1 (bytevector-length arg0)))
+  (inline "*((int16_t*)(arg0+arg1)) = arg2"))
+
+(define-c int16_t bytevector-s16-ref ((value ctx sexp) bytevector int sexp)
+  (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((int16_t*)(arg1+arg2)) : sexp_swap_s16(*((int16_t*)(arg1+arg2))))"))
+(define-c void bytevector-s16-set! ((value ctx sexp) bytevector int int16_t sexp)
+  (assert (< -1 arg2 (bytevector-length arg1)))
+  (inline "*((int16_t*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_s16(arg3))"))
+
+(define-c int32_t bytevector-s32-native-ref (bytevector int)
+  (inline "*((int32_t*)(arg0+arg1))"))
+(define-c void bytevector-s32-native-set! (bytevector int int32_t)
+  (assert (< -1 arg1 (bytevector-length arg0)))
+  (inline "*((int32_t*)(arg0+arg1)) = arg2"))
+
+(define-c int32_t bytevector-s32-ref ((value ctx sexp) bytevector int sexp)
+  (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((int32_t*)(arg1+arg2)) : sexp_swap_s32(*((int32_t*)(arg1+arg2))))"))
+(define-c void bytevector-s32-set! ((value ctx sexp) bytevector int int32_t sexp)
+  (assert (< -1 arg2 (bytevector-length arg1)))
+  (inline "*((int32_t*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_s32(arg3))"))
+
+(define-c int64_t bytevector-s64-native-ref (bytevector int)
+  (inline "*((int64_t*)(arg0+arg1))"))
+(define-c void bytevector-s64-native-set! (bytevector int int64_t)
+  (assert (< -1 arg1 (bytevector-length arg0)))
+  (inline "*((int64_t*)(arg0+arg1)) = arg2"))
+
+(define-c int64_t bytevector-s64-ref ((value ctx sexp) bytevector int sexp)
+  (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((int64_t*)(arg1+arg2)) : sexp_swap_s64(*((int64_t*)(arg1+arg2))))"))
+(define-c void bytevector-s64-set! ((value ctx sexp) bytevector int int64_t sexp)
+  (assert (< -1 arg2 (bytevector-length arg1)))
+  (inline "*((int64_t*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_s64(arg3))"))
+
+(define-c uint16_t bytevector-u16-native-ref (bytevector int)
+  (inline "*((uint16_t*)(arg0+arg1))"))
+(define-c void bytevector-u16-native-set! (bytevector int uint16_t)
+  (assert (< -1 arg1 (bytevector-length arg0)))
+  (inline "*((uint16_t*)(arg0+arg1)) = arg2"))
+
+(define-c uint16_t bytevector-u16-ref ((value ctx sexp) bytevector int sexp)
+  (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((uint16_t*)(arg1+arg2)) : sexp_swap_u16(*((uint16_t*)(arg1+arg2))))"))
+(define-c void bytevector-u16-set! ((value ctx sexp) bytevector int uint16_t sexp)
+  (assert (< -1 arg2 (bytevector-length arg1)))
+  (inline "*((uint16_t*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_u16(arg3))"))
+
+(define-c uint32_t bytevector-u32-native-ref (bytevector int)
+  (inline "*((uint32_t*)(arg0+arg1))"))
+(define-c void bytevector-u32-native-set! (bytevector int uint32_t)
+  (assert (< -1 arg1 (bytevector-length arg0)))
+  (inline "*((uint32_t*)(arg0+arg1)) = arg2"))
+
+(define-c uint32_t bytevector-u32-ref ((value ctx sexp) bytevector int sexp)
+  (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((uint32_t*)(arg1+arg2)) : sexp_swap_u32(*((uint32_t*)(arg1+arg2))))"))
+(define-c void bytevector-u32-set! ((value ctx sexp) bytevector int uint32_t sexp)
+  (assert (< -1 arg2 (bytevector-length arg1)))
+  (inline "*((uint32_t*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_u32(arg3))"))
+
+(define-c uint64_t bytevector-u64-native-ref (bytevector int)
+  (inline "*((uint64_t*)(arg0+arg1))"))
+(define-c void bytevector-u64-native-set! (bytevector int uint64_t)
+  (assert (< -1 arg1 (bytevector-length arg0)))
+  (inline "*((uint64_t*)(arg0+arg1)) = arg2"))
+
+(define-c uint64_t bytevector-u64-ref ((value ctx sexp) bytevector int sexp)
+  (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((uint64_t*)(arg1+arg2)) : sexp_swap_u64(*((uint64_t*)(arg1+arg2))))"))
+(define-c void bytevector-u64-set! ((value ctx sexp) bytevector int uint64_t sexp)
+  (assert (< -1 arg2 (bytevector-length arg1)))
+  (inline "*((uint64_t*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_u64(arg3))"))
+
+
+(define-c float bytevector-ieee-single-native-ref (bytevector int)
+  (inline "*((float*)(arg0+arg1))"))
+(define-c void bytevector-ieee-single-native-set! (bytevector int float)
+  (assert (< -1 arg1 (bytevector-length arg0)))
+  (inline "*((float*)(arg0+arg1)) = arg2"))
+
+(define-c float bytevector-ieee-single-ref ((value ctx sexp) bytevector int sexp)
+  (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((float*)(arg1+arg2)) : sexp_swap_float(*(float*)(arg1+arg2)))"))
+(define-c void bytevector-ieee-single-set! ((value ctx sexp) bytevector int float sexp)
+  (assert (< -1 arg2 (bytevector-length arg1)))
+  (inline "*((float*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_float(arg3))"))
+
+(define-c double bytevector-ieee-double-native-ref (bytevector int)
+  (inline "*((double*)(arg0+arg1))"))
+(define-c void bytevector-ieee-double-native-set! (bytevector int double)
+  (assert (< -1 arg1 (bytevector-length arg0)))
+  (inline "*((double*)(arg0+arg1)) = arg2"))
+
+(define-c double bytevector-ieee-double-ref ((value ctx sexp) bytevector int sexp)
+  (inline "(arg3 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? *((double*)(arg1+arg2)) : sexp_swap_double(*(double*)(arg1+arg2)))"))
+(define-c void bytevector-ieee-double-set! ((value ctx sexp) bytevector int double sexp)
+  (assert (< -1 arg2 (bytevector-length arg1)))
+  (inline "*((double*)(arg1+arg2)) = (arg4 == sexp_global(arg0, SEXP_G_ENDIANNESS) ? arg3 : sexp_swap_double(arg3))"))
+
+(define-c sexp (%string->utf16 "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)))

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);