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

8
test.scm
View File

@ -349,6 +349,14 @@
(pffi-define qsort libc-stdlib 'qsort 'void (list 'pointer 'int 'int 'callback)) (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 (pffi-define-callback compare
'int 'int
(list 'pointer 'pointer) (list 'pointer 'pointer)