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

Advancement on Kawa callback side

This commit is contained in:
retropikzel 2024-09-22 16:55:19 +03:00
parent 6aaf49e450
commit 0cecaac086
2 changed files with 59 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,5 +1,7 @@
(define arena (invoke-static java.lang.foreign.Arena 'global)) (define arena (invoke-static java.lang.foreign.Arena 'global))
(define method-handle-lookup (invoke-static java.lang.invoke.MethodHandles 'lookup))
(define native-linker (invoke-static java.lang.foreign.Linker 'nativeLinker))
(define value->object (define value->object
(lambda (value type) (lambda (value type)
@ -46,31 +48,6 @@
((equal? type 'callback) (static-field java.lang.foreign.ValueLayout 'ADDRESS)) ((equal? type 'callback) (static-field java.lang.foreign.ValueLayout 'ADDRESS))
(else (error "pffi-type->native-type -- No such pffi type" type))))) (else (error "pffi-type->native-type -- No such pffi type" type)))))
(define pffi-type->native-type-old
(lambda (type)
(cond
((equal? type 'int8) (static-field java.lang.foreign.ValueLayout 'JAVA_INT))
((equal? type 'uint8) (static-field java.lang.foreign.ValueLayout 'JAVA_INT))
((equal? type 'int16) (static-field java.lang.foreign.ValueLayout 'JAVA_INT))
((equal? type 'uint16) (static-field java.lang.foreign.ValueLayout 'JAVA_INT))
((equal? type 'int32) (static-field java.lang.foreign.ValueLayout 'JAVA_INT))
((equal? type 'uint32) (static-field java.lang.foreign.ValueLayout 'JAVA_INT))
((equal? type 'int64) (static-field java.lang.foreign.ValueLayout 'JAVA_INT))
((equal? type 'uint64) (static-field java.lang.foreign.ValueLayout 'JAVA_INT))
((equal? type 'char) (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR))
((equal? type 'unsigned-char) (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR))
((equal? type 'short) (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT))
((equal? type 'unsigned-short) (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT))
((equal? type 'int) (static-field java.lang.foreign.ValueLayout 'JAVA_INT))
((equal? type 'unsigned-int) (static-field java.lang.foreign.ValueLayout 'JAVA_INT))
((equal? type 'long) (static-field java.lang.foreign.ValueLayout 'JAVA_LONG))
((equal? type 'unsigned-long) (static-field java.lang.foreign.ValueLayout 'JAVA_LONG))
((equal? type 'float) (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT))
((equal? type 'double) (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE))
((equal? type 'pointer) (static-field java.lang.foreign.ValueLayout 'ADDRESS))
((equal? type 'void) (static-field java.lang.foreign.ValueLayout 'ADDRESS))
(else (error "pffi-type->function-argument-type -- No such pffi type" type)))))
(define pffi-pointer? (define pffi-pointer?
(lambda (object) (lambda (object)
(string=? (invoke (invoke object 'getClass) 'getName) (string=? (invoke (invoke object 'getClass) 'getName)
@ -96,20 +73,64 @@
'invokeWithArguments 'invokeWithArguments
(map value->object vals argument-types))))))) (map value->object vals argument-types)))))))
(define range
(lambda (from to)
(letrec*
((looper
(lambda (count result)
(if (= count to)
(append result (list count))
(looper (+ count 1) (append result (list count)))))))
(looper from (list)))))
(define-syntax pffi-define-callback (define-syntax pffi-define-callback
(syntax-rules () (syntax-rules ()
((_ scheme-name return-type argument-types procedure) ((_ scheme-name return-type argument-types procedure)
(define scheme-name (define scheme-name
(invoke (invoke (invoke-static java.lang.foreign.Linker 'nativeLinker) (let* ((helper-object (object () (callback procedure)))
'upcallStub (function-descriptor
procedure (let ((function-descriptor
(if (equal? return-type 'void) (if (equal? return-type 'void)
(apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid) (apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid)
(map pffi-type->native-type argument-types)) (map pffi-type->native-type argument-types))
(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)))))
arena)))))) (write function-descriptor)
(newline)
function-descriptor))
(method-type
(let ((method-type (invoke-static java.lang.invoke.MethodType
'methodType
(invoke int 'getClass)
(invoke java.lang.foreign.MemorySegment 'getClass)
(invoke java.lang.foreign.MemorySegment 'getClass)
)))
(write method-type)
(newline)
method-type))
(method-handle
(let ((method-handle
(invoke method-handle-lookup
'unreflect
((invoke (invoke helper-object 'getClass) 'getMethods) 0))))
(invoke method-handle-lookup 'revealDirect method-handle)
(set! method-handle (invoke method-handle 'asType method-type))
(write method-handle)
(newline)
method-handle)))
(invoke native-linker
'upcallStub
method-handle
function-descriptor
arena))))))
(define-syntax pffi-define-callback-old
(syntax-rules ()
((_ scheme-name return-type argument-types procedure)
(define scheme-name
(invoke-static java.lang.invoke.MethodType 'genericMethodType (length argument-types))
))))
(define pffi-size-of (define pffi-size-of
(lambda (type) (lambda (type)

3
test.scm
View File

@ -358,6 +358,9 @@
(cond ((> a b) 1) (cond ((> a b) 1)
((= a b) 0) ((= a b) 0)
((< a b) -1))))) ((< a b) -1)))))
(write compare)
(newline)
(exit)
(display "Unsorted: ") (display "Unsorted: ")
(write (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) (write (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0))