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

Merge pull request 'callback-racket' (#30) from callback-racket into master 

Reviewed-on: https://codeberg.org/r7rs-pffi/pffi/pulls/30
This commit is contained in:
retropikzel 2024-07-01 17:15:56 +00:00
parent c37e72bf8d b02222ad35
commit e74cddae4d
1 changed files with 103 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

195
retropikzel/pffi/v0-2-2/racket.rkt
View File

@ -1,109 +1,120 @@
#lang r7rs #lang r7rs
(define-library (define-library
(retropikzel pffi v0-2-2 racket) (retropikzel pffi v0-2-2 racket)
(import (scheme base) (import (scheme base)
(scheme write) (scheme write)
(scheme file) (scheme file)
(scheme process-context) (scheme process-context)
(compatibility mlist) (compatibility mlist)
(ffi unsafe) (ffi unsafe)
(ffi vector)) (ffi vector))
(export pffi-shared-object-load (export pffi-shared-object-load
pffi-define pffi-define
pffi-size-of pffi-define-callback
pffi-pointer-allocate pffi-size-of
pffi-pointer-null pffi-pointer-allocate
pffi-string->pointer pffi-pointer-null
pffi-pointer->string pffi-string->pointer
pffi-pointer-free pffi-pointer->string
pffi-pointer? pffi-pointer-free
pffi-pointer-null? pffi-pointer?
pffi-pointer-set! pffi-pointer-null?
pffi-pointer-get pffi-pointer-set!
pffi-pointer-deref) pffi-pointer-get
(begin pffi-pointer-deref)
(begin
(define pffi-type->native-type (define pffi-type->native-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) _int8) (cond ((equal? type 'int8) _int8)
((equal? type 'uint8) _uint8) ((equal? type 'uint8) _uint8)
((equal? type 'int16) _int16) ((equal? type 'int16) _int16)
((equal? type 'uint16) _uint16) ((equal? type 'uint16) _uint16)
((equal? type 'int32) _int32) ((equal? type 'int32) _int32)
((equal? type 'uint32) _uint32) ((equal? type 'uint32) _uint32)
((equal? type 'int64) _int64) ((equal? type 'int64) _int64)
((equal? type 'uint64) _uint64) ((equal? type 'uint64) _uint64)
((equal? type 'char) _int) ((equal? type 'char) _int)
((equal? type 'unsigned-char) _int) ((equal? type 'unsigned-char) _int)
((equal? type 'short) _short) ((equal? type 'short) _short)
((equal? type 'unsigned-short) _ushort) ((equal? type 'unsigned-short) _ushort)
((equal? type 'int) _int) ((equal? type 'int) _int)
((equal? type 'unsigned-int) _uint) ((equal? type 'unsigned-int) _uint)
((equal? type 'long) _long) ((equal? type 'long) _long)
((equal? type 'unsigned-long) _ulong) ((equal? type 'unsigned-long) _ulong)
((equal? type 'float) _float) ((equal? type 'float) _float)
((equal? type 'double) _double) ((equal? type 'double) _double)
((equal? type 'pointer) _pointer) ((equal? type 'pointer) _pointer)
((equal? type 'string) _pointer) ((equal? type 'string) _pointer)
((equal? type 'void) _void) ((equal? type 'void) _void)
(else (error "pffi-type->native-type -- No such pffi type" type))))) ((equal? type 'callback) _pointer)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(define pffi-pointer? (define pffi-pointer?
(lambda (object) (lambda (object)
(cpointer? object))) (cpointer? object)))
(define-syntax pffi-define (define-syntax pffi-define
(syntax-rules () (syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types) ((pffi-define scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
(get-ffi-obj c-name (get-ffi-obj c-name
shared-object shared-object
(_cprocedure (mlist->list (map pffi-type->native-type argument-types)) (_cprocedure (mlist->list (map pffi-type->native-type argument-types))
(pffi-type->native-type return-type))))))) (pffi-type->native-type return-type)))))))
(define pffi-size-of (define-syntax pffi-define-callback
(lambda (type) (syntax-rules ()
(ctype-sizeof (pffi-type->native-type type)))) ((pffi-define-callback scheme-name return-type argument-types procedure)
(define scheme-name (function-ptr procedure
(_cprocedure
(mlist->list (map pffi-type->native-type argument-types))
(pffi-type->native-type return-type)))
))))
(define pffi-pointer-allocate (define pffi-size-of
(lambda (size) (lambda (type)
(malloc size 'raw))) (ctype-sizeof (pffi-type->native-type type))))
(define pffi-pointer-null (define pffi-pointer-allocate
(lambda () (lambda (size)
#f ; In racket #f is null pointer (malloc size 'raw)))
))
(define pffi-string->pointer (define pffi-pointer-null
(lambda (string-content) (lambda ()
(cast string-content _string _pointer))) #f ; In racket #f is null pointer
))
(define pffi-pointer->string (define pffi-string->pointer
(lambda (pointer) (lambda (string-content)
(cast pointer _pointer _string))) (cast string-content _string _pointer)))
(define pffi-shared-object-load (define pffi-pointer->string
(lambda (header path) (lambda (pointer)
(ffi-lib path))) (cast pointer _pointer _string)))
(define pffi-pointer-free (define pffi-shared-object-load
(lambda (pointer) (lambda (header path)
(free pointer))) (ffi-lib path)))
(define pffi-pointer-null? (define pffi-pointer-free
(lambda (pointer) (lambda (pointer)
(not pointer) ; #f is the null pointer on racket (free pointer)))
))
(define pffi-pointer-set! (define pffi-pointer-null?
(lambda (pointer type offset value) (lambda (pointer)
(ptr-set! pointer (pffi-type->native-type type) offset value))) (not pointer) ; #f is the null pointer on racket
))
(define pffi-pointer-get (define pffi-pointer-set!
(lambda (pointer type offset) (lambda (pointer type offset value)
(ptr-ref pointer (pffi-type->native-type type) offset))) (ptr-set! pointer (pffi-type->native-type type) offset value)))
(define pffi-pointer-deref (define pffi-pointer-get
(lambda (pointer) (lambda (pointer type offset)
pointer)))) (ptr-ref pointer (pffi-type->native-type type) offset)))
(define pffi-pointer-deref
(lambda (pointer)
pointer))))