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

Small progress on Kawa callbacks

This commit is contained in:
retropikzel 2024-09-22 19:03:41 +03:00
parent 0ed645ab57
commit 7cba9b5d7e
2 changed files with 30 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -87,9 +87,10 @@
(syntax-rules ()
((_ scheme-name return-type argument-types procedure)
(define scheme-name
(let* ((helper-procedure
(lambda (a b)
(apply procedure (list a b))))
(let* ((helper-object
(object ()
((test1234 a b)
1)))
(function-descriptor
(let ((function-descriptor
(if (equal? return-type 'void)
@ -98,24 +99,40 @@
(apply (class-methods java.lang.foreign.FunctionDescriptor 'of)
(pffi-type->native-type return-type)
(map pffi-type->native-type argument-types)))))
(write (invoke (class-methods (invoke helper-object 'getClass) 'test1234) 'getName))
(newline)
(write function-descriptor)
(newline)
(write (invoke function-descriptor 'toMethodType))
(newline)
function-descriptor))
(method-type
(let ((method-type (invoke function-descriptor 'toMethodType)))
(let (
(method-type (invoke function-descriptor 'toMethodType))
;(method-type (field procedure 'applyMethodType))
)
(write method-type)
(newline)
method-type))
(method-handle
(let (
;(method-handle (invoke procedure 'getApplyMethod))
(method-handle (invoke (class-methods (invoke helper-object 'getClass) 'test1234) 'getApplyMethod))
#;(method-handle (invoke (class-methods (invoke helper-object 'getClass)
'test1234) 'getApplyMethod))
#;(method-handle (invoke method-handle-lookup
'findStatic
(invoke helper-object 'getClass)
(invoke (class-methods (invoke helper-object 'getClass) 'test1234) 'getName)
method-type
))
)
;(invoke method-handle-lookup 'revealDirect method-handle)
(write method-handle)
(newline)
(set! method-handle (invoke method-handle 'asType method-type))
;(set! method-handle (invoke method-handle 'asType method-type))
(write method-handle)
(newline)
method-handle)))

8
test.scm
View File

@ -349,6 +349,14 @@
(pffi-define qsort libc-stdlib 'qsort 'void (list 'pointer 'int 'int 'callback))
(define test1234
(lambda (pointer-a pointer-b)
(let ((a (pffi-pointer-get pointer-a 'int 0))
(b (pffi-pointer-get pointer-b 'int 0)))
(cond ((> a b) 1)
((= a b) 0)
((< a b) -1)))))
(pffi-define-callback compare
'int
(list 'pointer 'pointer)