Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added bytevector library

This commit is contained in:
retropikzel 2025-04-25 21:06:08 +03:00
parent 439c097ab0
commit 66ded0d1ee
17 changed files with 1298 additions and 227 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile
View File

@ -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." \

8
README.md
View File

@ -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
<a name="string-into-c-bytevector"></a>
#### utf8->c-bytevector
<a name="utf8-into-c-bytevector"></a>
**string->c-bytevector** string -> pointer
**utf8->c-bytevector** string -> pointer
Makes pointer out of a given string.

134
retropikzel/pffi.sld
View File

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

3
retropikzel/pffi/chibi.scm
View File

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

8
retropikzel/pffi/chicken.scm
View File

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

3
retropikzel/pffi/cyclone.scm
View File

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

3
retropikzel/pffi/gambit.scm
View File

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

10
retropikzel/pffi/guile.scm
View File

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

18
retropikzel/pffi/kawa.scm
View File

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

3
retropikzel/pffi/mosh.scm
View File

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

8
retropikzel/pffi/racket.scm
View File

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

4
retropikzel/pffi/sagittarius.scm
View File

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

1063
retropikzel/pffi/shared/c-bytevectors.scm Normal file
View File

File diff suppressed because it is too large Load Diff

64
retropikzel/pffi/shared/pointer.scm
View File

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

3
retropikzel/pffi/stklos.scm
View File

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

13
retropikzel/pffi/ypsilon.scm
View File

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

176
tests/compliance.scm
View File

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