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

Done

This commit is contained in:
retropikzel 2024-07-01 20:13:27 +03:00
parent 14bbd63d5f
commit 7c15de41e8
1 changed files with 102 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,118 +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-define-callback pffi-define-callback
pffi-size-of pffi-size-of
pffi-pointer-allocate pffi-pointer-allocate
pffi-pointer-null pffi-pointer-null
pffi-string->pointer pffi-string->pointer
pffi-pointer->string pffi-pointer->string
pffi-pointer-free pffi-pointer-free
pffi-pointer? pffi-pointer?
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-set! pffi-pointer-set!
pffi-pointer-get pffi-pointer-get
pffi-pointer-deref) pffi-pointer-deref)
(begin (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-syntax pffi-define-callback (define-syntax pffi-define-callback
(syntax-rules () (syntax-rules ()
((pffi-define-callback scheme-name return-type argument-types procedure) ((pffi-define-callback scheme-name return-type argument-types procedure)
(define scheme-name (define scheme-name (function-ptr procedure
(ffi-callback procedure (_cprocedure
(mlist->list (map pffi-type->native-type argument-types)) (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 pffi-size-of
(lambda (type) (lambda (type)
(ctype-sizeof (pffi-type->native-type type)))) (ctype-sizeof (pffi-type->native-type type))))
(define pffi-pointer-allocate (define pffi-pointer-allocate
(lambda (size) (lambda (size)
(malloc size 'raw))) (malloc size 'raw)))
(define pffi-pointer-null (define pffi-pointer-null
(lambda () (lambda ()
#f ; In racket #f is null pointer #f ; In racket #f is null pointer
)) ))
(define pffi-string->pointer (define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(cast string-content _string _pointer))) (cast string-content _string _pointer)))
(define pffi-pointer->string (define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
(cast pointer _pointer _string))) (cast pointer _pointer _string)))
(define pffi-shared-object-load (define pffi-shared-object-load
(lambda (header path) (lambda (header path)
(ffi-lib path))) (ffi-lib path)))
(define pffi-pointer-free (define pffi-pointer-free
(lambda (pointer) (lambda (pointer)
(free pointer))) (free pointer)))
(define pffi-pointer-null? (define pffi-pointer-null?
(lambda (pointer) (lambda (pointer)
(not pointer) ; #f is the null pointer on racket (not pointer) ; #f is the null pointer on racket
)) ))
(define pffi-pointer-set! (define pffi-pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(ptr-set! pointer (pffi-type->native-type type) offset value))) (ptr-set! pointer (pffi-type->native-type type) offset value)))
(define pffi-pointer-get (define pffi-pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(ptr-ref pointer (pffi-type->native-type type) offset))) (ptr-ref pointer (pffi-type->native-type type) offset)))
(define pffi-pointer-deref (define pffi-pointer-deref
(lambda (pointer) (lambda (pointer)
pointer)))) pointer))))