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

Improvements for Sagittarius

This commit is contained in:
retropikzel 2025-01-24 21:57:45 +02:00
parent cf0f269110
commit 8c2e9c4ec5
3 changed files with 20 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Makefile
View File

@ -114,10 +114,13 @@ test-mosh-podman-amd64: libtest.so
test-mosh: libtest.so test-mosh: libtest.so
${MOSH} test.scm ${MOSH} test.scm
SASH=sash -r7 -L . -L ./schubert SASH=sash --clean-cache -r7 -L . -L ./schubert
test-sagittarius-podman-amd64: libtest.so test-sagittarius-podman-amd64: libtest.so
podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/sagittarius bash -c "cd /workdir && ${SASH} test.scm" podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/sagittarius bash -c "cd /workdir && ${SASH} test.scm"
test-sagittarius-docker: libtest.so
docker run -it -v ${PWD}:/workdir docker.io/schemers/sagittarius bash -c "cd /workdir && ${SASH} test.scm"
test-sagittarius: libtest.so test-sagittarius: libtest.so
${SASH} test.scm ${SASH} test.scm

4
retropikzel/r7rs-pffi/kawa.scm
View File

@ -185,7 +185,7 @@
'reinterpret 'reinterpret
(static-field java.lang.Integer 'MAX_VALUE)) (static-field java.lang.Integer 'MAX_VALUE))
'set 'set
(invoke (pffi-type->native-type type) 'withByteAlignment 1) (invoke (pffi-type->native-type type) 'withByteAlignment (pffi-align-of type))
offset offset
value))) value)))
@ -194,6 +194,6 @@
(let ((r (invoke (invoke pointer 'reinterpret (let ((r (invoke (invoke pointer 'reinterpret
(static-field java.lang.Integer 'MAX_VALUE)) (static-field java.lang.Integer 'MAX_VALUE))
'get 'get
(invoke (pffi-type->native-type type) 'withByteAlignment 1) (invoke (pffi-type->native-type type) 'withByteAlignment (pffi-align-of type))
offset))) offset)))
r))) r)))

16
retropikzel/r7rs-pffi/sagittarius.scm
View File

@ -87,9 +87,17 @@
(lambda () (lambda ()
(empty-pointer))) (empty-pointer)))
(define (string->c-string s)
(let* ((bv (string->utf8 s))
(p (allocate-pointer (+ (bytevector-length bv) 1))))
(do ((i 0 (+ i 1)))
((= i (bytevector-length bv)) p)
(pointer-set-c-uint8! p i (bytevector-u8-ref bv i)))
p))
(define pffi-string->pointer (define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
string-content)) (string->c-string string-content)))
(define pffi-pointer->string (define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
@ -140,7 +148,11 @@
((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset)) ((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
((equal? type 'int64) (pointer-ref-c-int64_t pointer offset)) ((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset)) ((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
((equal? type 'char) (integer->char (pointer-ref-c-char pointer offset))) ((equal? type 'char)
(display "HERE: ")
(write pointer)
(newline)
(integer->char (pointer-ref-c-char pointer offset)))
((equal? type 'short) (pointer-ref-c-short pointer offset)) ((equal? type 'short) (pointer-ref-c-short pointer offset))
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset)) ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
((equal? type 'int) (pointer-ref-c-int pointer offset)) ((equal? type 'int) (pointer-ref-c-int pointer offset))