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

Added stklos support

This commit is contained in:
retropikzel 2025-04-02 06:40:35 +03:00
parent 76eb8058a8
commit d7de538744
2 changed files with 33 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
retropikzel/pffi.sld
View File

@ -461,7 +461,7 @@
pffi-struct-offset-get
pffi-struct-get
pffi-struct-set!
;pffi-define
pffi-define
;pffi-define-callback
))
(tr7

33
retropikzel/pffi/stklos.scm
View File

@ -26,17 +26,48 @@
(define pffi-pointer?
(lambda (object)
(display "HERE: ")
(write object)
(newline)
(write (cpointer? object))
(newline)
(cpointer? object)))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types)
(begin
(define pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) :int)
((equal? type 'uint8) :uint)
((equal? type 'int16) :int)
((equal? type 'uint16) :uint)
((equal? type 'int32) :int)
((equal? type 'uint32) :uint)
((equal? type 'int64) :int)
((equal? type 'uint64) :uint)
((equal? type 'char) :char)
((equal? type 'unsigned-char) :uchar)
((equal? type 'short) :short)
((equal? type 'unsigned-short) :ushort)
((equal? type 'int) :int)
((equal? type 'unsigned-int) :uint)
((equal? type 'long) :long)
((equal? type 'unsigned-long) :ulong)
((equal? type 'float) :float)
((equal? type 'double) :double)
((equal? type 'pointer) :pointer)
((equal? type 'string) :string)
((equal? type 'void) :void)
((equal? type 'struct) :void)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(define scheme-name
(make-external-function
(symbol->string c-name)
(map pffi-type->native-type argument-types)
(pffi-type->native-type return-type)
shared-object)))))
shared-object))))))
(define pffi-define-callback
(lambda ()