diff --git a/Makefile b/Makefile
index 20c8ba1..0168c3a 100644
--- a/Makefile
+++ b/Makefile
@@ -4,9 +4,6 @@ DOCKER=docker run -it -v ${PWD}:/workdir
DOCKER_INIT=cd /workdir && make clean &&
VERSION=$(shell grep "version:" README.md | awk '{split\($0,a\); print a[2];}')
-snow:
- snow-chibi --install-source-dir ./snow install "(r6rs bytevectors)"
-
# apt-get install pandoc weasyprint
docs:
mkdir -p documentation
@@ -72,7 +69,6 @@ test-compile-r7rs: tmp/test/libtest.o tmp/test/libtest.so tmp/test/libtest.a
cp -r retropikzel tmp/test/
cp tests/compliance.scm tmp/test/
cp tests/c-include/libtest.h tmp/test/
- cp -r snow/* tmp/test/
cd tmp/test && \
COMPILE_R7RS_GAMBIT="-cc-options \"-ltest -I. -L\" -ld-options \"-L.\"" \
COMPILE_R7RS_CHICKEN="-L -ltest -I. -L." \
diff --git a/README.md b/README.md
index 15aadb4..e7859a9 100644
--- a/README.md
+++ b/README.md
@@ -58,7 +58,7 @@ conforming to some specification.
- [c-free](#c-free)
- [pffi-pointer-set!](#pffi-pointer-set!)
- [pffi-pointer-get](#pffi-pointer-get)
- - [string->c-bytevector](#string-into-c-bytevector)
+ - [utf8->c-bytevector](#utf8-into-c-bytevector)
- [c-bytevector->sring](#c-bytevector-into-string)
- [pffi-struct-make](#pffi-struct-make)
- [pffi-struct-pointer](#pffi-struct-pointer)
@@ -479,10 +479,10 @@ Gets the value from a pointer on given offset. For example:
(pffi-pointer-get p 'int 64)
> 100
-#### string->c-bytevector
-
+#### utf8->c-bytevector
+
-**string->c-bytevector** string -> pointer
+**utf8->c-bytevector** string -> pointer
Makes pointer out of a given string.
diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld
index 200c0c0..a68f504 100644
--- a/retropikzel/pffi.sld
+++ b/retropikzel/pffi.sld
@@ -2,131 +2,133 @@
(retropikzel pffi) ; (foreign r7rs)? (foreign c)?
(cond-expand
(chibi
- (import (except (scheme base) bytevector-copy!)
+ (import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(chibi ast)
- (chibi)
- (r6rs bytevectors))
+ (scheme inexact)
+ (chibi))
(include-shared "pffi/chibi-pffi"))
(chicken
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
+ (scheme inexact)
(scheme process-context)
(chicken base)
(chicken foreign)
(chicken locative)
(chicken syntax)
(chicken memory)
- (chicken random)
- (r6rs bytevectors)))
+ (chicken random)))
(cyclone
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
+ (scheme inexact)
(scheme process-context)
(cyclone foreign)
- (scheme cyclone primitives)
- (r6rs bytevectors)))
+ (scheme cyclone primitives)))
(gambit
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
+ (scheme inexact)
(scheme process-context)
- (only (gambit) c-declare c-lambda c-define define-macro)
- (r6rs bytevectors)))
+ (only (gambit) c-declare c-lambda c-define define-macro)))
(gauche
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
+ (scheme inexact)
(scheme process-context)
(gauche base)
- (retropikzel pffi gauche)
- (r6rs bytevectors)))
+ (retropikzel pffi gauche)))
(gerbil
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
- (scheme process-context)
- (r6rs bytevectors)))
+ (scheme inexact)
+ (scheme process-context)))
(guile
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
+ (scheme inexact)
(scheme process-context)
(system foreign)
(system foreign-library)
- (only (guile) include-from-path)
- (rnrs bytevectors)))
+ (only (guile) include-from-path)))
(kawa
- (import (except (scheme base) bytevector-copy bytevector-copy!)
+ (import (scheme base)
(scheme write)
(scheme char)
(scheme file)
- (scheme process-context)
- (r6rs bytevectors)))
+ (scheme inexact)
+ (scheme process-context)))
(larceny
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
+ (scheme inexact)
(scheme process-context)
(rename (primitives r5rs:require) (r5rs:require require))
(primitives std-ffi)
(primitives foreign-procedure)
(primitives foreign-file)
- (primitives foreign-stdlib)
- (r6rs bytevectors)))
+ (primitives foreign-stdlib)))
(mosh
- (import (except (scheme base) bytevector-copy!)
+ (import (scheme base)
(scheme write)
(scheme char)
(scheme file)
+ (scheme inexact)
+ (scheme inexact)
(scheme process-context)
- (mosh ffi)
- (r6rs bytevectors)))
+ (mosh ffi)))
(racket
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
+ (scheme inexact)
(scheme process-context)
(only (racket base) system-type)
(ffi winapi)
(compatibility mlist)
(ffi unsafe)
- (ffi vector)
- (except (r6rs bytevectors) bytevector-copy!)))
+ (ffi vector)))
(sagittarius
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
+ (scheme inexact)
(scheme process-context)
(except (sagittarius ffi) c-free c-malloc)
- (sagittarius)
- (r6rs bytevectors)))
+ (sagittarius)))
(skint
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
- (scheme process-context)
- (r6rs bytevectors)))
+ (scheme inexact)
+ (scheme process-context)))
(stklos
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
+ (scheme inexact)
(scheme process-context)
(only (stklos)
make-external-function
@@ -172,8 +174,7 @@
pointer-ref-c-double
pointer-set-c-pointer!
pointer-ref-c-pointer
- void?)
- (r6rs bytevectors))
+ void?))
(export make-external-function
calculate-struct-size-and-offsets
struct-make
@@ -183,22 +184,18 @@
(scheme write)
(scheme char)
(scheme file)
- (scheme process-context)
- (r6rs bytevectors)))
+ ;(scheme inexact)
+ (scheme process-context)))
(ypsilon
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
+ (scheme inexact)
(scheme process-context)
(ypsilon c-ffi)
(ypsilon c-types)
- (only (core) define-macro syntax-case)
- (except (rnrs bytevectors)
- bytevector-copy!
- bytevector-copy
- string->utf8
- utf8->string))))
+ (only (core) define-macro syntax-case))))
(export ;; Primitives
c-size-of
define-c-library
@@ -207,19 +204,69 @@
c-bytevector?
pffi-pointer-set!;c-bytevector-u8-set! and so on
pffi-pointer-get;c-bytevector-u8-ref and so on
+ native-endianness
+ ;; TODO Docs for all of these
+ c-bytevector->address
+ address->c-bytevector
+ c-bytevector-s8-set!
+ c-bytevector-s8-ref
+ c-bytevector-u8-set!
+ c-bytevector-u8-ref
+ c-bytevector-s16-set!
+ c-bytevector-s16-native-set!
+ c-bytevector-s16-ref
+ c-bytevector-s16-native-ref
+ c-bytevector-u16-set!
+ c-bytevector-u16-native-set!
+ c-bytevector-u16-ref
+ c-bytevector-u16-native-ref
+ c-bytevector-s32-set!
+ c-bytevector-s32-native-set!
+ c-bytevector-s32-ref
+ c-bytevector-s32-native-ref
+ c-bytevector-u32-set!
+ c-bytevector-u32-native-set!
+ c-bytevector-u32-ref
+ c-bytevector-u32-native-ref
+ c-bytevector-s64-set!
+ c-bytevector-s64-native-set!
+ c-bytevector-s64-ref
+ c-bytevector-s64-native-ref
+ c-bytevector-u64-set!
+ c-bytevector-u64-native-set!
+ c-bytevector-u64-ref
+ c-bytevector-u64-native-ref
+ c-bytevector-sint-set!
+ c-bytevector-sint-native-set!
+ c-bytevector-sint-ref
+ c-bytevector-sint-native-ref
+ c-bytevector-uint-set!
+ c-bytevector-uint-native-set!
+ c-bytevector-uint-ref
+ c-bytevector-uint-native-ref
+ c-bytevector-ieee-single-set!
+ c-bytevector-ieee-single-native-set!
+ c-bytevector-ieee-single-ref
+ c-bytevector-ieee-single-native-ref
+ c-bytevector-ieee-double-set!
+ c-bytevector-ieee-double-native-set!
+ c-bytevector-ieee-double-ref
+ c-bytevector-ieee-double-native-ref
;; c-bytevector
make-c-bytevector
- c-bytevector ;; TODO Documentation, Testing
+ ;c-bytevector ;; TODO docs, tests
make-c-null
c-null?
c-free
- c-bytevector-string-length ;; TODO Documentation, Testing
+
+
+ c-string-length ;; TODO Documentation, Testing
bytevector->c-bytevector
c-bytevector->bytevector
call-with-address-of-c-bytevector ;; Todo Documentation
- string->c-bytevector
- c-bytevector->string
+ string->c-utf8
+ c-utf8->string
;c-bytevector-u8-ref ;; TODO Documentation, Testing
@@ -275,5 +322,6 @@
(include-relative "pffi/shared/struct.scm"))
(else (include "pffi/shared/main.scm")
(include "pffi/shared/struct.scm")
+ (include "pffi/shared/c-bytevectors.scm")
(include "pffi/shared/pointer.scm")
(include "pffi/shared/array.scm"))))
diff --git a/retropikzel/pffi/chibi.scm b/retropikzel/pffi/chibi.scm
index 2915a5c..d149e02 100644
--- a/retropikzel/pffi/chibi.scm
+++ b/retropikzel/pffi/chibi.scm
@@ -48,6 +48,9 @@
(lambda (pointer)
(pointer-free pointer)))
+(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
+(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
+
(define pffi-pointer-set!
(lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
diff --git a/retropikzel/pffi/chicken.scm b/retropikzel/pffi/chicken.scm
index af795b2..90b999a 100644
--- a/retropikzel/pffi/chicken.scm
+++ b/retropikzel/pffi/chicken.scm
@@ -165,6 +165,14 @@
(or (not pointer) ; #f counts as null pointer on Chicken
(= (pointer->address pointer) 0)))))
+(define c-bytevector-u8-ref
+ (lambda (c-bytevector k)
+ (pointer-s8-ref (pointer+ c-bytevector k))))
+
+(define c-bytevector-u8-set!
+ (lambda (c-bytevector k byte)
+ (pointer-s8-set! (pointer+ c-bytevector k) byte)))
+
(define pffi-pointer-set!
(lambda (pointer type offset value)
(cond
diff --git a/retropikzel/pffi/cyclone.scm b/retropikzel/pffi/cyclone.scm
index 05d00b8..60b8d7c 100644
--- a/retropikzel/pffi/cyclone.scm
+++ b/retropikzel/pffi/cyclone.scm
@@ -345,6 +345,9 @@
"make_c_opaque(opq, (void*)opaque_ptr(pointer) + obj_obj2int(offset));
return_closcall1(data, k, &opq);")
+(define c-bytevector-u8-set! pffi-pointer-uint8-set!)
+(define c-bytevector-u8-ref pffi-pointer-uint8-get)
+
(define pffi-pointer-get
(lambda (pointer type offset)
(cond
diff --git a/retropikzel/pffi/gambit.scm b/retropikzel/pffi/gambit.scm
index 3c2d145..34d2096 100644
--- a/retropikzel/pffi/gambit.scm
+++ b/retropikzel/pffi/gambit.scm
@@ -66,6 +66,9 @@
(lambda (x) #f)
(lambda () (pointer? object)))))))
+(define c-bytevector-u8-set! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
+(define c-bytevector-u8-ref (c-lambda ((pointer void) int) unsigned-int8 "___return(*(uint8_t*)((char*)___arg1 + ___arg2));"))
+
(define pointer-set-c-int8_t! (c-lambda ((pointer void) int int8) void "*(int8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-uint8_t! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-int16_t! (c-lambda ((pointer void) int int16) void "*(int16_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
diff --git a/retropikzel/pffi/guile.scm b/retropikzel/pffi/guile.scm
index 01d2d21..1638d29 100644
--- a/retropikzel/pffi/guile.scm
+++ b/retropikzel/pffi/guile.scm
@@ -57,6 +57,16 @@
(lambda (path options)
(load-foreign-library path)))
+(define c-bytevector-u8-set!
+ (lambda (c-bytevector k byte)
+ (let ((p (pointer->bytevector c-bytevector (+ k 100))))
+ (bytevector-u8-set! p k byte))))
+
+(define c-bytevector-u8-ref
+ (lambda (c-bytevector k)
+ (let ((p (pointer->bytevector c-bytevector (+ k 100))))
+ (bytevector-u8-ref p k))))
+
(define pffi-pointer-set!
(lambda (pointer type offset value)
(let ((p (pointer->bytevector pointer (+ offset 100))))
diff --git a/retropikzel/pffi/kawa.scm b/retropikzel/pffi/kawa.scm
index e9e91c9..6578e68 100644
--- a/retropikzel/pffi/kawa.scm
+++ b/retropikzel/pffi/kawa.scm
@@ -151,9 +151,25 @@
(list (cons 'linker linker)
(cons 'lookup lookup)))))
+(define null-pointer (make-c-null))
(define c-null?
(lambda (pointer)
- (invoke pointer 'equals (pffi-pointer-null))))
+ (invoke pointer 'equals null-pointer)))
+
+(define u8-value-layout (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1))
+(define c-bytevector-u8-set!
+ (lambda (c-bytevector k byte)
+ (invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
+ 'set
+ u8-value-layout
+ k
+ byte)))
+(define c-bytevector-u8-ref
+ (lambda (c-bytevector k)
+ (invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
+ 'get
+ u8-value-layout
+ k)))
(define pffi-pointer-set!
(lambda (pointer type offset value)
diff --git a/retropikzel/pffi/mosh.scm b/retropikzel/pffi/mosh.scm
index 3395f22..85cb796 100644
--- a/retropikzel/pffi/mosh.scm
+++ b/retropikzel/pffi/mosh.scm
@@ -32,6 +32,9 @@
(lambda (object)
(pointer? object)))
+(define c-bytevector-u8-set! pointer-set-c-uint8!)
+(define c-bytevector-u8-ref pointer-ref-c-uint8)
+
(define pffi-pointer-set!
(lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-c-int8! pointer offset value))
diff --git a/retropikzel/pffi/racket.scm b/retropikzel/pffi/racket.scm
index 3cfb1f2..295c9f4 100644
--- a/retropikzel/pffi/racket.scm
+++ b/retropikzel/pffi/racket.scm
@@ -61,6 +61,14 @@
(list #f))))
(ffi-lib path))))
+(define c-bytevector-u8-set!
+ (lambda (c-bytevector k byte)
+ (ptr-set! c-bytevector _uint8 'abs k byte)))
+
+(define c-bytevector-u8-ref
+ (lambda (c-bytevector k)
+ (ptr-ref c-bytevector _uint8 'abs k)))
+
(define pffi-pointer-set!
(lambda (pointer type offset value)
(ptr-set! pointer
diff --git a/retropikzel/pffi/sagittarius.scm b/retropikzel/pffi/sagittarius.scm
index f2aab32..e381c93 100644
--- a/retropikzel/pffi/sagittarius.scm
+++ b/retropikzel/pffi/sagittarius.scm
@@ -76,6 +76,10 @@
(lambda (object)
(pointer? object)))
+(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
+(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
+
+
(define pffi-pointer-set!
(lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
diff --git a/retropikzel/pffi/shared/c-bytevectors.scm b/retropikzel/pffi/shared/c-bytevectors.scm
new file mode 100644
index 0000000..c77a46d
--- /dev/null
+++ b/retropikzel/pffi/shared/c-bytevectors.scm
@@ -0,0 +1,1063 @@
+;;; Copyright 2025 Retropikzel
+;;;
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright and permission notice in full.
+;;;
+;;; This is R6RS c-Bytevectors library, modified to work with C pointers.
+;;; Mostly just by adding c- prefix to each word "bytevector".
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright 2015 William D Clinger.
+;;;
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright and permission notice in full.
+;;;
+;;; I also request that you send me a copy of any improvements that you
+;;; make to this software so that they may be incorporated within it to
+;;; the benefit of the Scheme community.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; This R7RS-portable implementation of (rnrs bytevectors) is
+;;; mostly derived from Larceny's src/Lib/Common/bytevector.sch.
+;;;
+;;; The R6RS requires implementations to select a native endianness.
+;;; That choice is arbitrary, intended to affect performance but not
+;;; behavior. In this implementation, the native endianness is
+;;; obtained via cond-expand, which should coincide with the
+;;; endianness obtained by calling the features procedure. Of the
+;;; R7RS systems I've tested, only one omits endianness from its
+;;; (features), and it's a slow interpreter for which the native
+;;; endianness probably won't affect performance.
+;;;
+;;; This implementation defines a 53-bit exact integer constant,
+;;; and the procedures that work with byte fields of arbitrary
+;;; width may create even larger exact integers.
+;;;
+;;; FIXME: It should be possible to delay creation of that 53-bit
+;;; constant until it's needed, which might be better for systems
+;;; that don't support exact 53-bit integers. It looks as though
+;;; most systems R7RS systems either support exact 53-bit integers
+;;; or overflow into inexact 53-bit integers; if the constant turns
+;;; out to be inexact, then the procedure that needs it will fail
+;;; when it is called, which is what would happen if creation of
+;;; that constant were delayed.
+
+;;; Local stuff.
+
+(define (complain who . irritants)
+ (apply error
+ (string-append "illegal arguments passed to "
+ (symbol->string who))
+ irritants))
+
+; Help syntax and procedures; not exported.
+
+(define-syntax unspecified
+ (syntax-rules ()
+ ((_) (if #f #f))))
+
+(define-syntax c-bytevector:div
+ (syntax-rules ()
+ ((_ x y) (quotient x y))))
+
+(define-syntax c-bytevector:mod
+ (syntax-rules ()
+ ((_ x y) (remainder x y))))
+
+(define-syntax u8->s8
+ (syntax-rules ()
+ ((_ octet0)
+ (let ((octet octet0))
+ (if (> octet 127)
+ (- octet 256)
+ octet)))))
+
+(define-syntax s8->u8
+ (syntax-rules ()
+ ((_ val0)
+ (let ((val val0))
+ (if (negative? val)
+ (+ val 256)
+ val)))))
+
+(define (make-uint-ref size)
+ (lambda (c-bytevector k endianness)
+ (c-bytevector-uint-ref c-bytevector k endianness size)))
+
+(define (make-sint-ref size)
+ (lambda (c-bytevector k endianness)
+ (c-bytevector-sint-ref c-bytevector k endianness size)))
+
+(define (make-uint-set! size)
+ (lambda (c-bytevector k n endianness)
+ (c-bytevector-uint-set! c-bytevector k n endianness size)))
+
+(define (make-sint-set! size)
+ (lambda (c-bytevector k n endianness)
+ (c-bytevector-sint-set! c-bytevector k n endianness size)))
+
+(define (make-ref/native base base-ref)
+ (lambda (c-bytevector index)
+ (ensure-aligned index base)
+ (base-ref c-bytevector index (native-endianness))))
+
+(define (make-set!/native base base-set!)
+ (lambda (c-bytevector index val)
+ (ensure-aligned index base)
+ (base-set! c-bytevector index val (native-endianness))))
+
+(define (ensure-aligned index base)
+ (if (not (zero? (c-bytevector:mod index base)))
+ (error "non-aligned c-bytevector access" index base)))
+
+#;(define (make-c-bytevector->int-list c-bytevector-ref)
+ (lambda (b endness size)
+ (let ((ref (lambda (i) (c-bytevector-ref b i endness size)))
+ (length (c-bytevector-length b)))
+ (let loop ((i 0) (r '()))
+ (if (>= i length)
+ (reverse r)
+ (loop (+ i size)
+ (cons (ref i) r)))))))
+
+(define (make-int-list->c-bytevector c-bytevector-set!)
+ (lambda (l endness size)
+ (let* ((c-bytevector (make-c-bytevector (* size (length l))))
+ (setter! (lambda (i n)
+ (c-bytevector-set! c-bytevector i n endness size))))
+ (let loop ((i 0) (l l))
+ (if (null? l)
+ c-bytevector
+ (begin
+ (setter! i (car l))
+ (loop (+ i size) (cdr l))))))))
+
+;;; Magic numbers for IEEE-754 single and double precision:
+;;;
+;;; the largest biased exponent (255 or 2047)
+;;; the exponent bias (127 or 1023)
+;;; the integer value of the hidden bit (2^23 or 2^52)
+
+(define c-bytevector:single-maxexponent 255)
+(define c-bytevector:single-bias
+ (c-bytevector:div c-bytevector:single-maxexponent 2))
+(define c-bytevector:single-hidden-bit (expt 2 23))
+
+(define c-bytevector:double-maxexponent 2047)
+(define c-bytevector:double-bias
+ (c-bytevector:div c-bytevector:double-maxexponent 2))
+(define c-bytevector:double-hidden-bit (expt 2 52)) ; must be exact integer
+
+(define two^48 (expt 2 48))
+(define two^40 (expt 2 40))
+(define two^32 (expt 2 32))
+(define two^24 (expt 2 24))
+(define two^16 (expt 2 16))
+(define two^8 (expt 2 8))
+
+;;; Given four exact integers, returns
+;;;
+;;; (-1)^sign * (2^exponent) * p/q
+;;;
+;;; as an inexact real.
+;;;
+;;; FIXME: this procedure is not used, but it might eventually
+;;; become relevant to a rewrite of this implementation so I'm
+;;; just commenting it out.
+
+#;
+(define (c-bytevector:normalized sign exponent p q)
+ (let* ((p/q (inexact (/ p q)))
+ (x (* p/q (expt 2.0 exponent))))
+ (cond ((= sign 0) x)
+ ((= x 0.0) -0.0)
+ (else (- x)))))
+
+;;; Given exact positive integers p and q,
+;;; returns three values:
+;;; exact integers exponent, p2, and q2 such that
+;;; q2 <= p2 < q2+q2
+;;; p / q = (p2 * 2^exponent) / q2
+
+(define (c-bytevector:normalized-ieee-parts p q)
+ (cond ((< p q)
+ (do ((p p (+ p p))
+ (e 0 (- e 1)))
+ ((>= p q)
+ (values e p q))))
+ ((<= (+ q q) p)
+ (do ((q q (+ q q))
+ (e 0 (+ e 1)))
+ ((< p (+ q q))
+ (values e p q))))
+ (else
+ (values 0 p q))))
+
+;;; Given an inexact real x, an exponent bias, and an exact positive
+;;; integer q that is a power of 2 representing the integer value of
+;;; the hidden bit, returns three exact integers:
+;;;
+;;; sign
+;;; biased-exponent
+;;; p
+;;;
+;;; If x is normalized, then 0 < biased-exponent <= bias+bias,
+;;; q <= p < 2*q, and
+;;;
+;;; x = (-1)^sign * (2^(biased-exponent - bias)) * p/q
+;;;
+;;; If x is denormalized, then p < q and the equation holds.
+;;; If x is zero, then biased-exponent and p are zero.
+;;; If x is infinity, then biased-exponent = bias+bias+1 and p=0.
+;;; If x is a NaN, then biased-exponent = bias+bias+1 and p>0.
+;;;
+
+(define (c-bytevector:ieee-parts x bias q)
+ (cond ((nan? x)
+ (values 0 (+ bias bias 1) (- q 1)))
+ ((infinite? x)
+ (values (if (positive? x) 0 1) (+ bias bias 1) 0))
+ ((zero? x)
+ (values (if (eqv? x -0.0) 1 0) 0 0))
+ (else
+ (let* ((sign (if (negative? x) 1 0))
+ (y (exact (abs x)))
+ (num (numerator y))
+ (den (denominator y)))
+ (call-with-values
+ (lambda () (c-bytevector:normalized-ieee-parts num den))
+ (lambda (exponent num den)
+ (let ((biased-exponent (+ exponent bias)))
+ (cond ((< 0 biased-exponent (+ bias bias 1))
+ ; within the range of normalized numbers
+ (if (<= den q)
+ (let* ((factor (/ q den))
+ (num*factor (* num factor)))
+ (if (integer? factor)
+ (values sign biased-exponent num*factor)
+ (error 'c-bytevector:ieee-parts
+ "this shouldn't happen: " x bias q)))
+ (let* ((factor (/ den q))
+ (num*factor (/ num factor)))
+ (values sign
+ biased-exponent
+ (round num*factor)))))
+ ((>= biased-exponent (+ bias bias 1))
+ ; infinity
+ (values (if (positive? x) 0 1) (+ bias bias 1) 0))
+ (else
+ ; denormalized
+ ; FIXME: this has the double rounding bug
+ (do ((biased biased-exponent (+ biased 1))
+ (num (round (/ (* q num) den))
+ (round (c-bytevector:div num 2))))
+ ((and (< num q) (= biased 1))
+ (values sign biased num))))))))))))
+
+;;; This procedure should work even if
+;;; exact integers are limited to as little as 20 bits
+;;; inexact reals are limited to IEEE single precision
+;;;
+;;; If inexact reals are limited to single precision, then
+;;; the result might overflow, but we can't help that.
+
+(define (c-bytevector-ieee-double-big-endian-ref c-bytevector k)
+ (let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 0)))
+ (byte1 (c-bytevector-u8-ref c-bytevector (+ k 1)))
+ (byte2 (c-bytevector-u8-ref c-bytevector (+ k 2)))
+ (byte3 (c-bytevector-u8-ref c-bytevector (+ k 3)))
+ (byte4 (c-bytevector-u8-ref c-bytevector (+ k 4)))
+ (byte5 (c-bytevector-u8-ref c-bytevector (+ k 5)))
+ (byte6 (c-bytevector-u8-ref c-bytevector (+ k 6)))
+ (byte7 (c-bytevector-u8-ref c-bytevector (+ k 7)))
+ (sign (quotient byte0 128))
+ (biased-exponent (+ (* 16 (remainder byte0 128))
+ (quotient byte1 16)))
+ (hibits (+ (* 65536 (remainder byte1 16))
+ (* 256 byte2)
+ byte3))
+ (midbits (+ (* 256 byte4) byte5))
+ (lobits (+ (* 256 byte6) byte7)))
+ (make-ieee-double sign biased-exponent hibits midbits lobits)))
+
+(define (c-bytevector-ieee-double-little-endian-ref c-bytevector k)
+ (let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 7)))
+ (byte1 (c-bytevector-u8-ref c-bytevector (+ k 6)))
+ (byte2 (c-bytevector-u8-ref c-bytevector (+ k 5)))
+ (byte3 (c-bytevector-u8-ref c-bytevector (+ k 4)))
+ (byte4 (c-bytevector-u8-ref c-bytevector (+ k 3)))
+ (byte5 (c-bytevector-u8-ref c-bytevector (+ k 2)))
+ (byte6 (c-bytevector-u8-ref c-bytevector (+ k 1)))
+ (byte7 (c-bytevector-u8-ref c-bytevector (+ k 0)))
+ (sign (quotient byte0 128))
+ (biased-exponent (+ (* 16 (remainder byte0 128))
+ (quotient byte1 16)))
+ (hibits (+ (* 65536 (remainder byte1 16))
+ (* 256 byte2)
+ byte3))
+ (midbits (+ (* 256 byte4) byte5))
+ (lobits (+ (* 256 byte6) byte7)))
+ (make-ieee-double sign biased-exponent hibits midbits lobits)))
+
+;;; This procedure should work even if
+;;; exact integers are limited to as little as 23 bits
+;;; inexact reals are limited to IEEE single precision
+
+(define (c-bytevector-ieee-single-big-endian-ref c-bytevector k)
+ (let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 0)))
+ (byte1 (c-bytevector-u8-ref c-bytevector (+ k 1)))
+ (byte2 (c-bytevector-u8-ref c-bytevector (+ k 2)))
+ (byte3 (c-bytevector-u8-ref c-bytevector (+ k 3)))
+ (sign (quotient byte0 128))
+ (biased-exponent (+ (* 2 (remainder byte0 128))
+ (quotient byte1 128)))
+ (bits (+ (* 65536 (remainder byte1 128))
+ (* 256 byte2)
+ byte3)))
+ (make-ieee-single sign biased-exponent bits)))
+
+(define (c-bytevector-ieee-single-little-endian-ref c-bytevector k)
+ (let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 3)))
+ (byte1 (c-bytevector-u8-ref c-bytevector (+ k 2)))
+ (byte2 (c-bytevector-u8-ref c-bytevector (+ k 1)))
+ (byte3 (c-bytevector-u8-ref c-bytevector (+ k 0)))
+ (sign (quotient byte0 128))
+ (biased-exponent (+ (* 2 (remainder byte0 128))
+ (quotient byte1 128)))
+ (bits (+ (* 65536 (remainder byte1 128))
+ (* 256 byte2)
+ byte3)))
+ (make-ieee-single sign biased-exponent bits)))
+
+;;; Given
+;;;
+;;; the sign bit
+;;; biased exponent
+;;; integer value of the 20 high order bits without the hidden bit
+;;; integer value of the 16 mid-order bits
+;;; integer value of the 16 low-order bits
+;;;
+;;; returns an inexact real approximating the IEEE double precision
+;;; number with the given representation. If an implementation
+;;; implements inexact reals using IEEE double precision, and
+;;; implements IEEE-754 arithmetic correctly, and the arguments
+;;; do not imply a NaN, then the inexact real that's returned
+;;; should be exactly right.
+
+(define (make-ieee-double sign biased-exponent hibits midbits lobits)
+ (cond ((= biased-exponent c-bytevector:double-maxexponent)
+ (if (zero? (+ hibits midbits lobits))
+ (if (= 0 sign)
+ +inf.0
+ -inf.0)
+ (if (= 0 sign)
+ +nan.0
+ -nan.0)))
+ ((= 0 biased-exponent)
+ (if (and (= 0 hibits)
+ (= 0 midbits)
+ (= 0 lobits))
+ (if (= 0 sign)
+ +0.0
+ -0.0)
+ (let* ((x (inexact hibits))
+ (x (+ (* 65536.0 x)
+ (inexact midbits)))
+ (x (+ (* 65536.0 x)
+ (inexact lobits)))
+ (two^51 2.251799813685248e15)
+ (x (/ x two^51))
+ (x (* x (expt 2.0 (- c-bytevector:double-bias)))))
+ (if (= 0 sign)
+ x
+ (- x)))))
+ (else
+ (let* ((hibits (+ #x100000 ; hidden bit
+ hibits))
+ (x (inexact hibits))
+ (x (+ (* 65536.0 x)
+ (inexact midbits)))
+ (x (+ (* 65536.0 x)
+ (inexact lobits)))
+ (two^52 4.503599627370496e15)
+ (x (/ x two^52))
+ (x (* x (expt 2.0
+ (- biased-exponent c-bytevector:double-bias)))))
+ (if (= 0 sign)
+ x
+ (- x))))))
+
+;;; Given
+;;;
+;;; the sign bit
+;;; biased exponent
+;;; integer value of the 23-bit mantissa without the hidden bit
+;;;
+;;; returns an inexact real approximating the IEEE single precision
+;;; number with the given representation. If an implementation
+;;; implements inexact reals using IEEE single or double precision,
+;;; and implements IEEE-754 arithmetic correctly, and the arguments
+;;; do not imply a NaN, then the inexact real that's returned
+;;; should be exactly right.
+
+(define (make-ieee-single sign biased-exponent bits)
+ (cond ((= biased-exponent c-bytevector:single-maxexponent)
+ (if (zero? bits)
+ (if (= 0 sign)
+ +inf.0
+ -inf.0)
+ (if (= 0 sign)
+ +nan.0
+ -nan.0)))
+ ((= 0 biased-exponent)
+ (if (= 0 bits)
+ (if (= 0 sign)
+ +0.0
+ -0.0)
+ (let* ((x (inexact bits))
+ (two^22 4194304.0)
+ (x (/ x two^22))
+ (x (* x (expt 2.0 (- c-bytevector:single-bias)))))
+ (if (= 0 sign)
+ x
+ (- x)))))
+ (else
+ (let* ((bits (+ #x800000 ; hidden bit
+ bits))
+ (x (inexact bits))
+ (two^23 8388608.0)
+ (x (/ x two^23))
+ (x (* x (expt 2.0
+ (- biased-exponent c-bytevector:single-bias)))))
+ (if (= 0 sign)
+ x
+ (- x))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Exported stuff.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; The R6RS allows implementations to support other symbols as well.
+
+(define-syntax endianness
+ (syntax-rules ()
+ ((_ big)
+ (quote big))
+ ((_ little)
+ (quote little))))
+
+(cond-expand
+ (little-endian
+ (define (native-endianness)
+ 'little))
+ (else
+ (define (native-endianness)
+ 'big)))
+
+;;; Already defined by (scheme base):
+;;;
+;;; c-bytevector? make-c-bytevector c-bytevector-length
+
+(define (c-bytevector=? bv1 bv2)
+ (if (and (c-bytevector? bv1)
+ (c-bytevector? bv2))
+ (equal? bv1 bv2)
+ (complain 'c-bytevector=? bv1 bv2)))
+
+#;(define (c-bytevector-fill! b fill)
+ (if (<= -128 fill -1)
+ (c-bytevector-fill! b (+ fill 256))
+ (let ((n (c-bytevector-length b)))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (c-bytevector-u8-set! b i fill)))))
+
+(define (r6rs:c-bytevector-copy! source source-start target target-start count)
+ (if (>= source-start target-start)
+ (do ((i 0 (+ i 1)))
+ ((>= i count))
+ (c-bytevector-u8-set! target
+ (+ target-start i)
+ (c-bytevector-u8-ref source (+ source-start i))))
+ (do ((i (- count 1) (- i 1)))
+ ((< i 0))
+ (c-bytevector-u8-set! target
+ (+ target-start i)
+ (c-bytevector-u8-ref source (+ source-start i))))))
+
+;;; Already defined by (scheme base), perhaps in greater generality:
+;;;
+;;; c-bytevector-copy
+;;; c-bytevector-u8-ref
+;;; c-bytevector-u8-set!
+
+(define (c-bytevector-s8-ref b k)
+ (u8->s8 (c-bytevector-u8-ref b k)))
+
+(define (c-bytevector-s8-set! b k val)
+ (c-bytevector-u8-set! b k (s8->u8 val)))
+
+#;(define (c-bytevector->u8-list b)
+ (let ((n (c-bytevector-length b)))
+ (do ((i (- n 1) (- i 1))
+ (result '() (cons (c-bytevector-u8-ref b i) result)))
+ ((< i 0)
+ result))))
+
+(define (u8-list->c-bytevector vals)
+ (let* ((n (length vals))
+ (b (make-c-bytevector n)))
+ (do ((vals vals (cdr vals))
+ (i 0 (+ i 1)))
+ ((null? vals))
+ (c-bytevector-u8-set! b i (car vals)))
+ b))
+
+(define (c-bytevector-uint-ref c-bytevector index endness size)
+ (case endness
+ ((big)
+ (do ((i 0 (+ i 1))
+ (result 0 (+ (* 256 result)
+ (c-bytevector-u8-ref c-bytevector (+ index i)))))
+ ((>= i size)
+ result)))
+ ((little)
+ (do ((i (- size 1) (- i 1))
+ (result 0 (+ (* 256 result)
+ (c-bytevector-u8-ref c-bytevector (+ index i)))))
+ ((< i 0)
+ result)))
+ (else
+ (c-bytevector-uint-ref c-bytevector index (native-endianness) size))))
+
+(define (c-bytevector-sint-ref c-bytevector index endness size)
+ (let* ((high-byte (c-bytevector-u8-ref c-bytevector
+ (if (eq? endness 'big)
+ index
+ (+ index size -1))))
+ (uresult (c-bytevector-uint-ref c-bytevector index endness size)))
+ (if (> high-byte 127)
+ (- uresult (expt 256 size))
+ uresult)))
+
+; FIXME: Some of these procedures may not do enough range checking.
+
+(define (c-bytevector-uint-set! c-bytevector index val endness size)
+ (case endness
+ ((little)
+ (do ((i 0 (+ i 1))
+ (val val (c-bytevector:div val 256)))
+ ((>= i size)
+ (unspecified))
+ (c-bytevector-u8-set! c-bytevector (+ index i) (c-bytevector:mod val 256))))
+ ((big)
+ (do ((i (- size 1) (- i 1))
+ (val val (c-bytevector:div val 256)))
+ ((< i 0)
+ (unspecified))
+ (c-bytevector-u8-set! c-bytevector (+ index i) (c-bytevector:mod val 256))))
+ (else
+ (c-bytevector-uint-set! c-bytevector index val (native-endianness) size))))
+
+(define (c-bytevector-sint-set! c-bytevector index val endness size)
+ (let ((uval (if (< val 0)
+ (+ val (expt 256 size))
+ val)))
+ (c-bytevector-uint-set! c-bytevector index uval endness size)))
+
+;(define c-bytevector->uint-list (make-c-bytevector->int-list c-bytevector-uint-ref))
+;(define c-bytevector->sint-list (make-c-bytevector->int-list c-bytevector-sint-ref))
+
+;(define uint-list->c-bytevector (make-int-list->c-bytevector c-bytevector-uint-set!))
+;(define sint-list->c-bytevector (make-int-list->c-bytevector c-bytevector-sint-set!))
+
+(define c-bytevector-u16-ref (make-uint-ref 2))
+(define c-bytevector-s16-ref (make-sint-ref 2))
+(define c-bytevector-u16-set! (make-uint-set! 2))
+(define c-bytevector-s16-set! (make-sint-set! 2))
+(define c-bytevector-u16-native-ref (make-ref/native 2 c-bytevector-u16-ref))
+(define c-bytevector-s16-native-ref (make-ref/native 2 c-bytevector-s16-ref))
+(define c-bytevector-u16-native-set! (make-set!/native 2 c-bytevector-u16-set!))
+(define c-bytevector-s16-native-set! (make-set!/native 2 c-bytevector-s16-set!))
+
+(define c-bytevector-u32-ref (make-uint-ref 4))
+(define c-bytevector-s32-ref (make-sint-ref 4))
+(define c-bytevector-u32-set! (make-uint-set! 4))
+(define c-bytevector-s32-set! (make-sint-set! 4))
+(define c-bytevector-u32-native-ref (make-ref/native 4 c-bytevector-u32-ref))
+(define c-bytevector-s32-native-ref (make-ref/native 4 c-bytevector-s32-ref))
+(define c-bytevector-u32-native-set! (make-set!/native 4 c-bytevector-u32-set!))
+(define c-bytevector-s32-native-set! (make-set!/native 4 c-bytevector-s32-set!))
+
+(define c-bytevector-u64-ref (make-uint-ref 8))
+(define c-bytevector-s64-ref (make-sint-ref 8))
+(define c-bytevector-u64-set! (make-uint-set! 8))
+(define c-bytevector-s64-set! (make-sint-set! 8))
+(define c-bytevector-u64-native-ref (make-ref/native 8 c-bytevector-u64-ref))
+(define c-bytevector-s64-native-ref (make-ref/native 8 c-bytevector-s64-ref))
+(define c-bytevector-u64-native-set! (make-set!/native 8 c-bytevector-u64-set!))
+(define c-bytevector-s64-native-set! (make-set!/native 8 c-bytevector-s64-set!))
+
+(cond-expand
+ (little-endian
+ (define (c-bytevector-ieee-single-native-ref c-bytevector k)
+ (if (not (= 0 (remainder k 4)))
+ (complain 'c-bytevector-ieee-single-native-ref c-bytevector k))
+ (c-bytevector-ieee-single-little-endian-ref c-bytevector k))
+ (define (c-bytevector-ieee-double-native-ref c-bytevector k)
+ (if (not (= 0 (remainder k 8)))
+ (complain 'c-bytevector-ieee-double-native-ref c-bytevector k))
+ (c-bytevector-ieee-double-little-endian-ref c-bytevector k))
+ (define (c-bytevector-ieee-single-native-set! c-bytevector k x)
+ (if (not (= 0 (remainder k 4)))
+ (complain 'c-bytevector-ieee-single-native-set! c-bytevector k x))
+ (c-bytevector-ieee-single-set! c-bytevector k x 'little))
+ (define (c-bytevector-ieee-double-native-set! c-bytevector k x)
+ (if (not (= 0 (remainder k 8)))
+ (complain 'c-bytevector-ieee-double-native-set! c-bytevector k x))
+ (c-bytevector-ieee-double-set! c-bytevector k x 'little)))
+ (else
+ (define (c-bytevector-ieee-single-native-ref c-bytevector k)
+ (if (not (= 0 (remainder k 4)))
+ (complain 'c-bytevector-ieee-single-native-ref c-bytevector k))
+ (c-bytevector-ieee-single-big-endian-ref c-bytevector k))
+ (define (c-bytevector-ieee-double-native-ref c-bytevector k)
+ (if (not (= 0 (remainder k 8)))
+ (complain 'c-bytevector-ieee-double-native-ref c-bytevector k))
+ (c-bytevector-ieee-double-big-endian-ref c-bytevector k))
+ (define (c-bytevector-ieee-single-native-set! c-bytevector k x)
+ (if (not (= 0 (remainder k 4)))
+ (complain 'c-bytevector-ieee-single-native-set! c-bytevector k x))
+ (c-bytevector-ieee-single-set! c-bytevector k x 'big))
+ (define (c-bytevector-ieee-double-native-set! c-bytevector k x)
+ (if (not (= 0 (remainder k 8)))
+ (complain 'c-bytevector-ieee-double-native-set! c-bytevector k x))
+ (c-bytevector-ieee-double-set! c-bytevector k x 'big))))
+
+(define (c-bytevector-ieee-single-ref c-bytevector k endianness)
+ (case endianness
+ ((big)
+ (c-bytevector-ieee-single-big-endian-ref c-bytevector k))
+ ((little)
+ (c-bytevector-ieee-single-little-endian-ref c-bytevector k))
+ (else
+ (complain 'c-bytevector-ieee-single-ref c-bytevector k endianness))))
+
+(define (c-bytevector-ieee-double-ref c-bytevector k endianness)
+ (case endianness
+ ((big)
+ (c-bytevector-ieee-double-big-endian-ref c-bytevector k))
+ ((little)
+ (c-bytevector-ieee-double-little-endian-ref c-bytevector k))
+ (else
+ (complain 'c-bytevector-ieee-double-ref c-bytevector k endianness))))
+
+(define (c-bytevector-ieee-single-set! c-bytevector k x endianness)
+ (call-with-values
+ (lambda ()
+ (c-bytevector:ieee-parts x
+ c-bytevector:single-bias
+ c-bytevector:single-hidden-bit))
+ (lambda (sign biased-exponent frac)
+ (define (store! sign biased-exponent frac)
+ (if (eq? 'big endianness)
+ (begin
+ (c-bytevector-u8-set! c-bytevector k
+ (+ (* 128 sign)
+ (c-bytevector:div biased-exponent 2)))
+ (c-bytevector-u8-set! c-bytevector (+ k 1)
+ (+ (* 128 (c-bytevector:mod biased-exponent 2))
+ (c-bytevector:div frac (* 256 256))))
+ (c-bytevector-u8-set! c-bytevector (+ k 2)
+ (c-bytevector:div
+ (c-bytevector:mod frac (* 256 256)) 256))
+ (c-bytevector-u8-set! c-bytevector (+ k 3)
+ (c-bytevector:mod frac 256)))
+ (begin
+ (c-bytevector-u8-set! c-bytevector (+ k 3)
+ (+ (* 128 sign)
+ (c-bytevector:div biased-exponent 2)))
+ (c-bytevector-u8-set! c-bytevector (+ k 2)
+ (+ (* 128 (c-bytevector:mod biased-exponent 2))
+ (c-bytevector:div frac (* 256 256))))
+ (c-bytevector-u8-set! c-bytevector (+ k 1)
+ (c-bytevector:div
+ (c-bytevector:mod frac (* 256 256)) 256))
+ (c-bytevector-u8-set! c-bytevector k
+ (c-bytevector:mod frac 256))))
+ (unspecified))
+ (cond ((= biased-exponent c-bytevector:single-maxexponent)
+ (store! sign biased-exponent frac))
+ ((< frac c-bytevector:single-hidden-bit)
+ (store! sign 0 frac))
+ (else
+ (store! sign biased-exponent
+ (- frac c-bytevector:single-hidden-bit)))))))
+
+(define (c-bytevector-ieee-double-set! c-bytevector k x endianness)
+ (call-with-values
+ (lambda ()
+ (c-bytevector:ieee-parts x
+ c-bytevector:double-bias
+ c-bytevector:double-hidden-bit))
+ (lambda (sign biased-exponent frac)
+
+ (define (store! sign biased-exponent frac)
+ (c-bytevector-u8-set! c-bytevector (+ k 7)
+ (+ (* 128 sign)
+ (c-bytevector:div biased-exponent 16)))
+ (c-bytevector-u8-set! c-bytevector (+ k 6)
+ (+ (* 16 (c-bytevector:mod biased-exponent 16))
+ (c-bytevector:div frac two^48)))
+ (c-bytevector-u8-set! c-bytevector (+ k 5)
+ (c-bytevector:div (c-bytevector:mod frac two^48)
+ two^40))
+ (c-bytevector-u8-set! c-bytevector (+ k 4)
+ (c-bytevector:div (c-bytevector:mod frac two^40)
+ two^32))
+ (c-bytevector-u8-set! c-bytevector (+ k 3)
+ (c-bytevector:div (c-bytevector:mod frac two^32)
+ two^24))
+ (c-bytevector-u8-set! c-bytevector (+ k 2)
+ (c-bytevector:div (c-bytevector:mod frac two^24)
+ two^16))
+ (c-bytevector-u8-set! c-bytevector (+ k 1)
+ (c-bytevector:div (c-bytevector:mod frac two^16)
+ 256))
+ (c-bytevector-u8-set! c-bytevector k
+ (c-bytevector:mod frac 256))
+ (if (not (eq? endianness 'little))
+ (begin (swap! (+ k 0) (+ k 7))
+ (swap! (+ k 1) (+ k 6))
+ (swap! (+ k 2) (+ k 5))
+ (swap! (+ k 3) (+ k 4))))
+ (unspecified))
+
+ (define (swap! i j)
+ (let ((bi (c-bytevector-u8-ref c-bytevector i))
+ (bj (c-bytevector-u8-ref c-bytevector j)))
+ (c-bytevector-u8-set! c-bytevector i bj)
+ (c-bytevector-u8-set! c-bytevector j bi)))
+
+ (cond ((= biased-exponent c-bytevector:double-maxexponent)
+ (store! sign biased-exponent frac))
+ ((< frac c-bytevector:double-hidden-bit)
+ (store! sign 0 frac))
+ (else
+ (store! sign biased-exponent
+ (- frac c-bytevector:double-hidden-bit)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; Conversions between c-bytevectors and strings.
+;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Already defined by (scheme base), with greater generality:
+;;;
+;;; string->utf8
+;;; utf8->string
+
+; (utf-16-codec) might write a byte order mark,
+; so it's better not to use textual i/o for this.
+
+(define (string->utf16 string . rest)
+ (let* ((endianness (cond ((null? rest)
+ 'big)
+ ((not (null? (cdr rest)))
+ (apply complain 'string->utf16 string rest))
+ ((eq? (car rest) 'big)
+ 'big)
+ ((eq? (car rest) 'little)
+ 'little)
+ (else
+ (apply complain 'string->utf16 string rest))))
+
+ ; endianness-dependent adjustments to indexing
+
+ (hi (if (eq? 'big endianness) 0 1))
+ (lo (- 1 hi))
+
+ (n (string-length string)))
+
+ (define (result-length)
+ (do ((i 0 (+ i 1))
+ (k 0 (let ((sv (char->integer (string-ref string i))))
+ (if (< sv #x10000) (+ k 2) (+ k 4)))))
+ ((= i n) k)))
+
+ (let ((bv (make-c-bytevector (result-length))))
+
+ (define (loop i k)
+ (if (< i n)
+ (let ((sv (char->integer (string-ref string i))))
+ (if (< sv #x10000)
+ (let ((hibits (quotient sv 256))
+ (lobits (remainder sv 256)))
+ (c-bytevector-u8-set! bv (+ k hi) hibits)
+ (c-bytevector-u8-set! bv (+ k lo) lobits)
+ (loop (+ i 1) (+ k 2)))
+ (let* ((x (- sv #x10000))
+ (hibits (quotient x 1024))
+ (lobits (remainder x 1024))
+ (hi16 (+ #xd800 hibits))
+ (lo16 (+ #xdc00 lobits))
+ (hi1 (quotient hi16 256))
+ (lo1 (remainder hi16 256))
+ (hi2 (quotient lo16 256))
+ (lo2 (remainder lo16 256)))
+ (c-bytevector-u8-set! bv (+ k hi) hi1)
+ (c-bytevector-u8-set! bv (+ k lo) lo1)
+ (c-bytevector-u8-set! bv (+ k hi 2) hi2)
+ (c-bytevector-u8-set! bv (+ k lo 2) lo2)
+ (loop (+ i 1) (+ k 4)))))))
+
+ (loop 0 0)
+ bv)))
+
+;;; The second argument to utf16->string should be optional,
+;;; and was optional in the R5.94RS draft, but was made mandatory
+;;; in the R5.95RS draft by someone who misinterpreted John Cowan's
+;;; response of 27 May 2007 to an ambiguous question posed by
+;;; Mike Sperber. This error was not spotted by anyone, and
+;;; made its way into the ratified R6RS.
+;;;
+;;; This implementation does not perpetuate that error. In this
+;;; implementation, the second argument is optional.
+;;;
+;;; The R6RS also contradicts itself by saying the c-bytevector
+;;; will be decoded according to UTF-16BE or UTF-16LE, which
+;;; implies any BOM must be ignored. I believe the intended
+;;; specification was along these lines:
+;;;
+;;; c-Bytevector is decoded acccording to UTF-16, UTF-16BE,
+;;; UTF-16LE, or a fourth encoding scheme that differs from
+;;; all three of those, depending upon the optional arguments
+;;; endianness and endianness-mandatory. If endianness
+;;; is the symbol big and endianness-mandatory is absent
+;;; or false, then c-bytevector is decoded according to
+;;; UTF-16. If endianness is the symbol big and
+;;; endianness-mandatory is #t, then c-bytevector is decoded
+;;; according to UTF-16BE. If endianness is the symbol
+;;; little and endianness-mandatory is #t, then c-bytevector
+;;; is decoded according to UTF-16LE. If endianness is
+;;; the symbol little and endianness-mandatory is absent
+;;; or #f, then the c-bytevector is decoded according to
+;;; UTF-16 if it begins with a BOM but is decoded according
+;;; to UTF-16LE if it does not begin with a BOM; note that
+;;; this fourth decoding does not correspond to any of the
+;;; Unicode encoding schemes that are defined by the Unicode
+;;; standard.
+;;;
+;;; That is the specification implemented here.
+
+#;(define (utf16->string c-bytevector . rest)
+ (let* ((n (c-bytevector-length c-bytevector))
+
+ (begins-with-bom?
+ (and (<= 2 n)
+ (let ((b0 (c-bytevector-u8-ref c-bytevector 0))
+ (b1 (c-bytevector-u8-ref c-bytevector 1)))
+ (or (and (= b0 #xfe) (= b1 #xff) 'big)
+ (and (= b0 #xff) (= b1 #xfe) 'little)))))
+
+ (mandatory? (cond ((or (null? rest) (null? (cdr rest)))
+ #f)
+ ((and (null? (cddr rest))
+ (boolean? (cadr rest)))
+ (cadr rest))
+ (else
+ (apply complain 'utf16->string c-bytevector rest))))
+
+ (endianness (cond ((null? rest)
+ (or begins-with-bom? 'big))
+ ((eq? (car rest) 'big)
+ (if mandatory?
+ 'big
+ (or begins-with-bom? 'big)))
+ ((eq? (car rest) 'little)
+ (if mandatory?
+ 'little
+ (or begins-with-bom? 'little)))
+ (else (apply complain
+ 'utf16->string
+ c-bytevector rest))))
+
+ (begins-with-bom? (if mandatory? #f begins-with-bom?))
+
+ (endianness (if mandatory? (car rest) endianness))
+
+ ; endianness-dependent adjustments to indexing
+
+ (hi (if (eq? 'big endianness) 0 1))
+ (lo (- 1 hi))
+
+ (replacement-character (integer->char #xfffd)))
+
+ ; computes the length of the encoded string
+
+ (define (result-length)
+ (define (loop i k)
+ (if (>= i n)
+ k
+ (let ((octet (c-bytevector-u8-ref c-bytevector i)))
+ (cond ((< octet #xd8)
+ (loop (+ i 2) (+ k 1)))
+ ((< octet #xdc)
+ (let* ((i2 (+ i 2))
+ (octet2 (if (< i2 n)
+ (c-bytevector-u8-ref c-bytevector i2)
+ 0)))
+ (if (<= #xdc octet2 #xdf)
+ (loop (+ i 4) (+ k 1))
+ ; bad surrogate pair, becomes replacement character
+ (loop i2 (+ k 1)))))
+ (else (loop (+ i 2) (+ k 1)))))))
+ (if begins-with-bom?
+ (loop (+ hi 2) 0)
+ (loop hi 0)))
+
+ (if (odd? n)
+ (error "c-bytevector passed to utf16->string has odd length" c-bytevector))
+
+ (let ((s (make-string (result-length))))
+ (define (loop i k)
+ (if (< i n)
+ (let ((hibits (c-bytevector-u8-ref c-bytevector (+ i hi)))
+ (lobits (c-bytevector-u8-ref c-bytevector (+ i lo))))
+ (cond ((< hibits #xd8)
+ (let ((c (integer->char
+ (+ (* hibits 256)
+ lobits))))
+ (string-set! s k c))
+ (loop (+ i 2) (+ k 1)))
+ ((< hibits #xdc)
+ (let* ((i2 (+ i hi 2))
+ (i3 (+ i lo 2))
+ (octet2 (if (< i2 n)
+ (c-bytevector-u8-ref c-bytevector i2)
+ 0))
+ (octet3 (if (< i2 n)
+ (c-bytevector-u8-ref c-bytevector i3)
+ 0)))
+ (if (<= #xdc octet2 #xdf)
+ (let* ((sv (+ #x10000
+ (* #x0400
+ (remainder
+ (+ (* hibits 256)
+ lobits)
+ #x0400))
+ (remainder
+ (+ (* octet2 256)
+ octet3)
+ #x0400)))
+ (c (if (<= #x10000 sv #x10ffff)
+ (integer->char sv)
+ replacement-character)))
+ (string-set! s k c)
+ (loop (+ i 4) (+ k 1)))
+ ; bad surrogate pair
+ (begin (string-set! s k replacement-character)
+ (loop (+ i 2) (+ k 1))))))
+ ((< hibits #xe0)
+ ; second surrogate not preceded by a first surrogate
+ (string-set! s k replacement-character)
+ (loop (+ i 2) (+ k 1)))
+ (else
+ (let ((c (integer->char
+ (+ (* hibits 256)
+ lobits))))
+ (string-set! s k c))
+ (loop (+ i 2) (+ k 1)))))))
+ (if begins-with-bom?
+ (loop 2 0)
+ (loop 0 0))
+ s)))
+
+;;; There is no utf-32-codec, so we can't use textual i/o for this.
+
+(define (string->utf32 string . rest)
+ (let* ((endianness (cond ((null? rest) 'big)
+ ((eq? (car rest) 'big) 'big)
+ ((eq? (car rest) 'little) 'little)
+ (else (apply complain
+ 'string->utf32
+ string
+ rest))))
+ (n (string-length string))
+ (result (make-c-bytevector (* 4 n))))
+ (do ((i 0 (+ i 1)))
+ ((= i n) result)
+ (c-bytevector-u32-set! result
+ (* 4 i)
+ (char->integer (string-ref string i))
+ endianness))))
+
+;;; There is no utf-32-codec, so we can't use textual i/o for this.
+
+#;(define (utf32->string c-bytevector . rest)
+ (let* ((n (c-bytevector-length c-bytevector))
+
+ (begins-with-bom?
+ (and (<= 4 n)
+ (let ((b0 (c-bytevector-u8-ref c-bytevector 0))
+ (b1 (c-bytevector-u8-ref c-bytevector 1))
+ (b2 (c-bytevector-u8-ref c-bytevector 2))
+ (b3 (c-bytevector-u8-ref c-bytevector 3)))
+ (or (and (= b0 0) (= b1 0) (= b2 #xfe) (= b3 #xff)
+ 'big)
+ (and (= b0 #xff) (= b1 #xfe) (= b2 0) (= b3 0)
+ 'little)))))
+
+ (mandatory? (cond ((or (null? rest) (null? (cdr rest)))
+ #f)
+ ((and (null? (cddr rest))
+ (boolean? (cadr rest)))
+ (cadr rest))
+ (else
+ (apply complain 'utf32->string c-bytevector rest))))
+
+ (endianness (cond ((null? rest)
+ (or begins-with-bom? 'big))
+ ((eq? (car rest) 'big)
+ (if mandatory?
+ 'big
+ (or begins-with-bom? 'big)))
+ ((eq? (car rest) 'little)
+ (if mandatory?
+ 'little
+ (or begins-with-bom? 'little)))
+ (else (apply complain
+ 'utf32->string
+ c-bytevector
+ rest))))
+
+ (begins-with-bom? (if mandatory? #f begins-with-bom?))
+
+ (endianness (if mandatory? (car rest) endianness))
+
+ (i0 (if begins-with-bom? 4 0))
+
+ (result (if (zero? (remainder n 4))
+ (make-string (quotient (- n i0) 4))
+ (complain
+ "c-bytevector passed to utf32->string has bad length"
+ c-bytevector))))
+
+ (do ((i i0 (+ i 4))
+ (j 0 (+ j 1)))
+ ((= i n) result)
+ (let* ((sv (c-bytevector-u32-ref c-bytevector i endianness))
+ (sv (cond ((< sv #xd800) sv)
+ ((< sv #xe000) #xfffd) ; replacement character
+ ((< sv #x110000) sv)
+ (else #xfffd))) ; replacement character
+ (c (integer->char sv)))
+ (string-set! result j c)))))
diff --git a/retropikzel/pffi/shared/pointer.scm b/retropikzel/pffi/shared/pointer.scm
index 7b12f0e..b54e6ec 100644
--- a/retropikzel/pffi/shared/pointer.scm
+++ b/retropikzel/pffi/shared/pointer.scm
@@ -8,7 +8,6 @@
"c"
'((additional-versions ("0" "6"))))))
-(define-c-procedure c-strlen libc 'strlen 'int '(pointer))
(define-c-procedure pffi-pointer-allocate-calloc libc 'calloc 'pointer '(int int))
(define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int))
(define-c-procedure c-memset-pointer->address libc 'memset 'uint64 '(pointer uint8 int))
@@ -38,10 +37,9 @@
(pointer (make-c-bytevector bytes-length))
(looper (lambda (index)
(when (< index bytes-length)
- (pffi-pointer-set! pointer
- 'uint8
- index
- (bytevector-u8-ref bytes index))
+ (c-bytevector-u8-set! pointer
+ index
+ (bytevector-u8-ref bytes index))
(looper (+ index 1))))))
(looper 0)
pointer)))
@@ -50,7 +48,7 @@
(lambda (pointer size)
(letrec* ((bytes (make-bytevector size))
(looper (lambda (index)
- (let ((byte (pffi-pointer-get pointer 'uint8 index)))
+ (let ((byte (c-bytevector-u8-ref pointer index)))
(if (= index size)
bytes
(begin
@@ -58,22 +56,18 @@
(looper (+ index 1))))))))
(looper 0))))
-(define c-bytevector-string-length
- (lambda (bytevector)
- (c-strlen bytevector)))
+(define c-string-length
+ (lambda (bytevector-var)
+ (c-strlen bytevector-var)))
-(define c-bytevector->string
- (lambda (pointer)
- (when (not (c-bytevector? pointer))
- (error "c-bytevector->string argument not c-bytevector" pointer))
- (let ((size (c-strlen pointer)))
- (utf8->string (c-bytevector->bytevector pointer size)))))
+(define c-utf8->string
+ (lambda (c-bytevector)
+ (let ((size (c-strlen c-bytevector)))
+ (utf8->string (c-bytevector->bytevector c-bytevector size)))))
-(define string->c-bytevector
- (lambda (text)
- (when (not (string? text))
- (error "string->bytevector argument not string" text))
- (bytevector->c-bytevector (string->utf8 (string-append text (string #\null))))))
+(define string->c-utf8
+ (lambda (string-var)
+ (bytevector->c-bytevector (string->utf8 (string-append string-var (string #\null))))))
(cond-expand
(kawa #t) ; FIXME
@@ -94,12 +88,36 @@
(= (c-memset-pointer->address pointer 0 0) 0)
#f)))))
+(define c-bytevector->address
+ (lambda (c-bytevector)
+ (c-memset-pointer->address c-bytevector 0 0)))
+
+(define address->c-bytevector
+ (lambda (address)
+ (c-memset-address->pointer address 0 0)))
+
+(define c-bytevector-pointer-set!
+ (lambda (c-bytevector k pointer)
+ (c-bytevector-uint-set! c-bytevector
+ 0
+ (c-bytevector->address pointer)
+ (native-endianness)
+ (c-size-of 'pointer))))
+
+(define c-bytevector-pointer-ref
+ (lambda (c-bytevector k)
+ (address->c-bytevector (c-bytevector-uint-ref c-bytevector
+ 0
+ (native-endianness)
+ (c-size-of 'pointer)))))
+
(define-syntax call-with-address-of-c-bytevector
(syntax-rules ()
((_ input-pointer thunk)
(let ((address-pointer (make-c-bytevector (c-size-of 'pointer))))
- (pffi-pointer-set! address-pointer 'pointer 0 input-pointer)
+ ;(pffi-pointer-set! address-pointer 'pointer 0 input-pointer)
+ (c-bytevector-pointer-set! address-pointer 0 input-pointer)
(apply thunk (list address-pointer))
- (set! input-pointer (pffi-pointer-get address-pointer 'pointer 0))
+ ;(set! input-pointer (pffi-pointer-get address-pointer 'pointer 0))
+ (set! input-pointer (c-bytevector-pointer-ref address-pointer 0))
(c-free address-pointer)))))
-
diff --git a/retropikzel/pffi/stklos.scm b/retropikzel/pffi/stklos.scm
index e9babd6..f6ad69c 100644
--- a/retropikzel/pffi/stklos.scm
+++ b/retropikzel/pffi/stklos.scm
@@ -90,6 +90,9 @@
((equal? type 'double) 8)
((equal? type 'pointer) 8))))
+(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
+(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
+
(define pffi-pointer-set!
(lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
diff --git a/retropikzel/pffi/ypsilon.scm b/retropikzel/pffi/ypsilon.scm
index f59d640..e83f098 100644
--- a/retropikzel/pffi/ypsilon.scm
+++ b/retropikzel/pffi/ypsilon.scm
@@ -29,6 +29,19 @@
(lambda (object)
(number? object)))
+(define c-bytevector-u8-set!
+ (lambda (c-bytevector k byte)
+ (bytevector-c-int8-set! (make-bytevector-mapping (+ c-bytevector k)
+ (c-size-of 'uint8))
+ 0
+ byte)))
+
+(define c-bytevector-u8-ref
+ (lambda (c-bytevector k)
+ (bytevector-c-int8-ref (make-bytevector-mapping (+ c-bytevector k)
+ (c-size-of 'uint8))
+ 0)))
+
(define pffi-pointer-set!
(lambda (pointer type offset value)
(let ((bv (make-bytevector-mapping (+ pointer offset) (c-size-of type))))
diff --git a/tests/compliance.scm b/tests/compliance.scm
index 6604552..ba00d65 100755
--- a/tests/compliance.scm
+++ b/tests/compliance.scm
@@ -446,20 +446,20 @@
(define-c-procedure c-puts libc-stdlib 'puts 'int '(pointer))
(debug c-puts)
-(define chars-written (c-puts (string->c-bytevector "puts: Hello from testing, I am C function puts")))
+(define chars-written (c-puts (string->c-utf8 "puts: Hello from testing, I am C function puts")))
(debug chars-written)
(assert = chars-written 47)
(define-c-procedure c-atoi libc-stdlib 'atoi 'int '(pointer))
-(assert = (c-atoi (string->c-bytevector "100")) 100)
+(assert = (c-atoi (string->c-utf8 "100")) 100)
(define-c-procedure c-fopen libc-stdio 'fopen 'pointer '(pointer pointer))
-(define output-file (c-fopen (string->c-bytevector "testfile.test")
- (string->c-bytevector "w")))
+(define output-file (c-fopen (string->c-utf8 "testfile.test")
+ (string->c-utf8 "w")))
(debug output-file)
(define-c-procedure c-fprintf libc-stdio 'fprintf 'int '(pointer pointer))
(define characters-written
- (c-fprintf output-file (string->c-bytevector "Hello world")))
+ (c-fprintf output-file (string->c-utf8 "Hello world")))
(debug characters-written)
(assert equal? (= characters-written 11) #t)
(define-c-procedure c-fclose libc-stdio 'fclose 'int '(pointer))
@@ -508,7 +508,7 @@
(assert equal? (c-null? 100) #f)
(assert equal? (c-null? 'bar) #f)
-;;make-c-bytevector
+;; make-c-bytevector
(print-header 'make-c-bytevector )
@@ -520,8 +520,15 @@
;(assert equal? (c-bytevector? "Hello world") #f)
(assert equal? (c-null? test-pointer) #f)
-;; call-with-address-of-c-bytevector
+(print-header "c-bytevector-u8-set! c-bytevector-u8-ref")
+(define u8-pointer (make-c-bytevector (c-size-of 'uint8)))
+(c-bytevector-u8-set! u8-pointer 0 42)
+(debug u8-pointer)
+(debug (c-bytevector-u8-ref u8-pointer 0))
+(assert equal? (= (c-bytevector-u8-ref u8-pointer 0) 42) #t)
+
+;; call-with-address-of-c-bytevector
(print-header 'call-with-address-of-c-bytevector)
@@ -532,15 +539,15 @@
'(pointer pointer))
(define input-pointer (make-c-bytevector (c-size-of 'int)))
-(pffi-pointer-set! input-pointer 'int 0 100)
-(debug (pffi-pointer-get input-pointer 'int 0))
+(c-bytevector-s32-native-set! input-pointer 0 100)
+(debug (c-bytevector-s32-native-ref input-pointer 0))
(call-with-address-of-c-bytevector
input-pointer
(lambda (address)
(test-passing-pointer-address input-pointer address)))
(debug input-pointer)
-(debug (pffi-pointer-get input-pointer 'int 0))
-(assert equal? (= (pffi-pointer-get input-pointer 'int 0) 42) #t)
+(debug (c-bytevector-s32-native-ref input-pointer 0))
+(assert equal? (= (c-bytevector-s32-native-ref input-pointer 0) 42) #t)
;; c-free
@@ -551,59 +558,6 @@
(c-free pointer-to-be-freed)
(debug pointer-to-be-freed)
-;; pffi-pointer-set! and pffi-pointer-get 1/2
-
-(print-header "pffi-pointer-set! and pffi-pointer-get 1/2")
-
-(define set-pointer (make-c-bytevector 256))
-(define offset 64)
-(define value 1)
-(debug set-pointer)
-(debug offset)
-(debug value)
-
-(cond-expand
- (gambit
- (define test-type
- (lambda (type)
- (begin
- (pffi-pointer-set! set-pointer type offset value)
- (assert = (pffi-pointer-get set-pointer type offset) value)))))
- (else
- (define-syntax test-type
- (syntax-rules ()
- ((_ type)
- (begin
- (pffi-pointer-set! set-pointer type offset value)
- (assert = (pffi-pointer-get set-pointer type offset) value)))))))
-
-(test-type 'int8)
-(test-type 'uint8)
-(test-type 'int16)
-(test-type 'uint16)
-(test-type 'int32)
-(test-type 'uint32)
-(test-type 'int64)
-(test-type 'uint64)
-(test-type 'short)
-(test-type 'unsigned-short)
-(test-type 'int)
-(test-type 'unsigned-int)
-(test-type 'long)
-(test-type 'unsigned-long)
-
-(pffi-pointer-set! set-pointer 'char offset #\X)
-(debug (pffi-pointer-get set-pointer 'char offset))
-(assert char=? (pffi-pointer-get set-pointer 'char offset) #\X)
-
-(pffi-pointer-set! set-pointer 'float offset 1.5)
-(debug (pffi-pointer-get set-pointer 'float offset))
-(assert = (pffi-pointer-get set-pointer 'float offset) 1.5)
-
-(pffi-pointer-set! set-pointer 'double offset 1.5)
-(debug (pffi-pointer-get set-pointer 'double offset))
-(assert = (pffi-pointer-get set-pointer 'double offset) 1.5)
-
; pffi-define-struct
(print-header "pffi-define-struct")
@@ -672,86 +626,6 @@
(debug (list bt1 bt2))
(assert equal? bt1 bt2)
-;; string->c-bytevector
-
-(print-header 'string->c-bytevector)
-
-(define string-pointer (string->c-bytevector "Hello world"))
-(debug string-pointer)
-(debug (c-bytevector->string string-pointer))
-(assert equal? (c-bytevector? string-pointer) #t)
-(assert equal? (c-null? string-pointer) #f)
-(debug (pffi-pointer-get string-pointer 'char 0))
-(assert char=? (pffi-pointer-get string-pointer 'char 0) #\H)
-(debug (pffi-pointer-get string-pointer 'char 1))
-(assert char=? (pffi-pointer-get string-pointer 'char 1) #\e)
-(debug (pffi-pointer-get string-pointer 'char 2))
-(assert char=? (pffi-pointer-get string-pointer 'char 2) #\l)
-(debug (pffi-pointer-get string-pointer 'char 3))
-(assert char=? (pffi-pointer-get string-pointer 'char 3) #\l)
-(debug (pffi-pointer-get string-pointer 'char 4))
-(assert char=? (pffi-pointer-get string-pointer 'char 4) #\o)
-(debug (pffi-pointer-get string-pointer 'char 10))
-(assert char=? (pffi-pointer-get string-pointer 'char 10) #\d)
-
-;; c-bytevector->string
-
-(print-header 'c-bytevector->string)
-
-(define pointer-string (c-bytevector->string string-pointer))
-(debug pointer-string)
-(assert equal? (string? pointer-string) #t)
-(assert string=? pointer-string "Hello world")
-(assert string=? (c-bytevector->string (string->c-bytevector "https://scheme.org")) "https://scheme.org")
-(define test-url-string "https://scheme.org")
-(debug test-url-string)
-(define test-url (string->c-bytevector test-url-string))
-(debug test-url)
-(debug (c-bytevector->string test-url))
-(assert equal? (string=? (c-bytevector->string test-url) test-url-string) #t)
-
-;; pffi-pointer-get
-
-(print-header "pffi-pointer-get")
-
-(define hello-string "hello")
-(define hello-string-pointer (string->c-bytevector hello-string))
-
-(debug (pffi-pointer-get hello-string-pointer 'char 0))
-(assert char=? (pffi-pointer-get hello-string-pointer 'char 0) #\h)
-(debug (pffi-pointer-get hello-string-pointer 'char 1))
-(assert char=? (pffi-pointer-get hello-string-pointer 'char 1) #\e)
-(debug (pffi-pointer-get hello-string-pointer 'char 4))
-(assert char=? (pffi-pointer-get hello-string-pointer 'char 4) #\o)
-
-;; pffi-pointer-set! and pffi-pointer-get 2/2
-
-(print-header "pffi-pointer-set! and pffi-pointer-get 2/2")
-
-(define pointer-to-be-set (string->c-bytevector "FOOBAR"))
-(debug pointer-to-be-set)
-(debug (c-bytevector->string pointer-to-be-set))
-(pffi-pointer-set! set-pointer 'pointer offset pointer-to-be-set)
-
-(debug (pffi-pointer-get set-pointer 'pointer offset))
-(assert equal?
- (c-bytevector? (pffi-pointer-get set-pointer 'pointer offset))
- #t)
-(debug (c-bytevector->string (pffi-pointer-get set-pointer 'pointer offset)))
-(assert equal?
- (string? (c-bytevector->string (pffi-pointer-get set-pointer 'pointer offset)))
- #t)
-(debug (c-bytevector->string (pffi-pointer-get set-pointer 'pointer offset)))
-(assert equal?
- (string=? (c-bytevector->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR")
- #t)
-
-(define string-to-be-set "FOOBAR")
-(debug string-to-be-set)
-(pffi-pointer-set! set-pointer 'pointer offset (string->c-bytevector string-to-be-set))
-(assert string=? (c-bytevector->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR")
-
-
;; pffi-struct-get
(print-header 'pffi-struct-get)
@@ -806,8 +680,8 @@
(debug (pffi-struct-get struct-test 'f))
(assert = (pffi-struct-get struct-test 'f) 6.0)
(debug (pffi-struct-get struct-test 'g))
-(debug (c-bytevector->string (pffi-struct-get struct-test 'g)))
-(assert equal? (string=? (c-bytevector->string (pffi-struct-get struct-test 'g)) "FOOBAR") #t)
+(debug (c-utf8->string (pffi-struct-get struct-test 'g)))
+(assert equal? (string=? (c-utf8->string (pffi-struct-get struct-test 'g)) "FOOBAR") #t)
(debug (pffi-struct-get struct-test 'h))
(assert = (pffi-struct-get struct-test 'h) 8)
(debug (pffi-struct-get struct-test 'i))
@@ -851,7 +725,7 @@
(pffi-struct-set! struct-test1 'd #\d)
(pffi-struct-set! struct-test1 'e (make-c-null))
(pffi-struct-set! struct-test1 'f 6.0)
-(pffi-struct-set! struct-test1 'g (string->c-bytevector "foo"))
+(pffi-struct-set! struct-test1 'g (string->c-utf8 "foo"))
(pffi-struct-set! struct-test1 'h 8)
(pffi-struct-set! struct-test1 'i (make-c-null))
(pffi-struct-set! struct-test1 'j 10)
@@ -900,8 +774,8 @@
;(assert equal? (c-null? (pffi-struct-get struct-test2 'e)) #t)
;(debug (pffi-struct-get struct-test2 'f))
;(assert = (pffi-struct-get struct-test2 'f) 6.0)
-;(debug (c-bytevector->string (pffi-struct-get struct-test2 'g)))
-;(assert equal? (string=? (c-bytevector->string (pffi-struct-get struct-test2 'g)) "FOOBAR") #t)
+;(debug (c-utf8->string (pffi-struct-get struct-test2 'g)))
+;(assert equal? (string=? (c-bytevector->utf8 (pffi-struct-get struct-test2 'g)) "FOOBAR") #t)
;(debug (pffi-struct-get struct-test2 'h))
;(assert = (pffi-struct-get struct-test2 'h) 8)
;(debug (pffi-struct-get struct-test2 'i))
@@ -961,8 +835,6 @@
;(debug (pffi-struct-set! struct-color 'a 103))
;(assert = (c-color-check-by-value (pffi-struct-dereference struct-color)) 0)
-(exit 0)
-
;(print-header "pffi-struct-dereference 2")
;(define-c-procedure c-test-check-by-value c-testlib 'test_check_by_value 'int '((struct . test)))
@@ -989,7 +861,7 @@
;(debug (pffi-struct-set! struct-test3 'd #\d))
;(debug (pffi-struct-set! struct-test3 'e (make-c-null)))
;(debug (pffi-struct-set! struct-test3 'f 6.0))
-;(debug (pffi-struct-set! struct-test3 'g (string->c-bytevector "foo")))
+;(debug (pffi-struct-set! struct-test3 'g (string->c-utf8 "foo")))
;(debug (pffi-struct-set! struct-test3 'h 8))
;(debug (pffi-struct-set! struct-test3 'i (make-c-null)))
;(debug (pffi-struct-set! struct-test3 'j 10))