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

Adding stklos support

This commit is contained in:
retropikzel 2025-04-01 20:34:19 +03:00
parent 12bdd2d00b
commit 76eb8058a8
4 changed files with 45 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
retropikzel/pffi.sld
View File

@ -454,8 +454,8 @@
pffi-pointer-free pffi-pointer-free
pffi-pointer-set! pffi-pointer-set!
pffi-pointer-get pffi-pointer-get
;pffi-string->pointer pffi-string->pointer
;pffi-pointer->string pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get

2
retropikzel/pffi/gauche.scm
View File

@ -14,7 +14,7 @@
pffi-define)) pffi-define))
(select-module retropikzel.pffi.gauche) (select-module retropikzel.pffi.gauche)
(dynamic-load "retropikzel/pffi/retropikzel-pffi-gauche") (dynamic-load "retropikzel/pffi/gauche-pffi")
(define size-of-type (define size-of-type
(lambda (type) (lambda (type)

6
retropikzel/pffi/shared/main.scm
View File

@ -222,5 +222,7 @@
(write searched-paths) (write searched-paths)
(newline) (newline)
(exit 1)) (exit 1))
(pffi-shared-object-load shared-object (cond-expand
`((additional-versions ,additional-versions))))))))))) (stklos shared-object)
(else (pffi-shared-object-load shared-object
`((additional-versions ,additional-versions)))))))))))))

54
retropikzel/pffi/stklos.scm
View File

@ -83,20 +83,6 @@
(free-bytes p) (free-bytes p)
p))) p)))
#;(define pffi-string->pointer
(lambda (string-content)
string-content))
#;(define pffi-pointer->string
(lambda (pointer)
(if (string? pointer)
pointer
(cpointer->string pointer))))
(define pffi-shared-object-load
(lambda (header path options)
path))
(define pffi-pointer-free (define pffi-pointer-free
(lambda (pointer) (lambda (pointer)
(free-bytes pointer))) (free-bytes pointer)))
@ -108,8 +94,44 @@
(define pffi-pointer-set! (define pffi-pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(error "Not implemented"))) (cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value))
((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value))
((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value))
((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
((equal? type 'char) (pointer-set-c-char! pointer offset value))
((equal? type 'short) (pointer-set-c-short! pointer offset value))
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
((equal? type 'int) (pointer-set-c-int! pointer offset value))
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value))
((equal? type 'long) (pointer-set-c-long! pointer offset value))
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
((equal? type 'float) (pointer-set-c-float! pointer offset value))
((equal? type 'double) (pointer-set-c-double! pointer offset value))
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
(define pffi-pointer-get (define pffi-pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(error "Not implemented"))) (cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
((equal? type 'int16) (pointer-ref-c-int16_t pointer offset))
((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset))
((equal? type 'int32) (pointer-ref-c-int32_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 'uint64) (pointer-ref-c-uint64_t pointer offset))
((equal? type 'char) (pointer-ref-c-char pointer offset))
((equal? type 'short) (pointer-ref-c-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 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
((equal? type 'long) (pointer-ref-c-long pointer offset))
((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
((equal? type 'float) (pointer-ref-c-float pointer offset))
((equal? type 'double) (pointer-ref-c-double pointer offset))
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))