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

Fix bug on Chibi implementation

This commit is contained in:
retropikzel 2024-11-14 06:38:14 +02:00
parent 25bdc6806b
commit 72b6251c70
3 changed files with 27 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
retropikzel/r7rs-pffi.sld
View File

@ -122,22 +122,22 @@
(scheme process-context))) (scheme process-context)))
(else (error "Unsupported implementation"))) (else (error "Unsupported implementation")))
(export pffi-init (export pffi-init
;pffi-size-of pffi-size-of
;pffi-shared-object-auto-load pffi-shared-object-auto-load
;pffi-shared-object-load pffi-shared-object-load
;pffi-pointer-null pffi-pointer-null
;pffi-pointer-null? pffi-pointer-null?
;pffi-pointer-allocate pffi-pointer-allocate
;pffi-pointer? pffi-pointer?
;pffi-pointer-free pffi-pointer-free
;pffi-pointer-set! pffi-pointer-set!
;pffi-pointer-get pffi-pointer-get
;pffi-string->pointer pffi-string->pointer
;pffi-pointer->string pffi-pointer->string
;pffi-define pffi-define
;pffi-define-callback ;pffi-define-callback
;pffi-pointer-address ;pffi-pointer-address
;pffi-pointer-dereference pffi-pointer-dereference
) )
(cond-expand (cond-expand
(chibi (include "r7rs-pffi/chibi.scm")) (chibi (include "r7rs-pffi/chibi.scm"))

17
retropikzel/r7rs-pffi/chibi.scm
View File

@ -1,9 +1,5 @@
(define pffi-init (lambda () #t)) (define pffi-init (lambda () #t))
;(write (scheme-procedure-to-pointer (lambda () (display "Hello"))))
;(newline)
;(exit)
(define pffi-size-of (define pffi-size-of
(lambda (type) (lambda (type)
(cond ((eq? type 'int8) (size-of-int8_t)) (cond ((eq? type 'int8) (size-of-int8_t))
@ -174,6 +170,11 @@
(define make-c-function (define make-c-function
(lambda (shared-object return-type c-name argument-types) (lambda (shared-object return-type c-name argument-types)
(display "Argument types: ")
(write argument-types)
(newline)
(write (length argument-types))
(newline)
(dlerror) ;; Clean all previous errors (dlerror) ;; Clean all previous errors
(let ((func (dlsym shared-object c-name)) (let ((func (dlsym shared-object c-name))
(maybe-dlerror (dlerror)) (maybe-dlerror (dlerror))
@ -183,14 +184,14 @@
(pffi-size-of return-type))))) (pffi-size-of return-type)))))
(when (not (pffi-pointer-null? maybe-dlerror)) (when (not (pffi-pointer-null? maybe-dlerror))
(error (pffi-pointer->string maybe-dlerror))) (error (pffi-pointer->string maybe-dlerror)))
(lambda (argument-1 . arguments) (lambda arguments
(internal-ffi-call (length argument-types) (internal-ffi-call (length argument-types)
(pffi-type->libffi-type return-type) (pffi-type->libffi-type return-type)
(map pffi-type->libffi-type argument-types) (map pffi-type->libffi-type argument-types)
func func
return-value return-value
(map argument->pointer (map argument->pointer
(append (list argument-1) arguments) arguments
argument-types)) argument-types))
(cond ((equal? return-type 'pointer) (cond ((equal? return-type 'pointer)
return-value) return-value)
@ -216,3 +217,7 @@
((pffi-define scheme-name return-type argument-types procedure) ((pffi-define scheme-name return-type argument-types procedure)
(define scheme-name (define scheme-name
(make-c-callback return-type argument-types procedure))))) (make-c-callback return-type argument-types procedure)))))
(define pffi-pointer-dereference
(lambda (pointer)
pointer))

4
retropikzel/r7rs-pffi/gambit.scm
View File

@ -51,8 +51,8 @@
((eq? type 'pointer) (size-of-void*)) ((eq? type 'pointer) (size-of-void*))
(else (error "Can not get size of unknown type" type))))) (else (error "Can not get size of unknown type" type)))))
(define-macro (pffi-shared-object-load headers) (define-macro (pffi-shared-object-load header)
`(c-declare "#include <stdint.h>")) `(c-declare ,(string-append "#include <" header ">")))
#;(define-syntax pffi-shared-object-load #;(define-syntax pffi-shared-object-load
(syntax-rules () (syntax-rules ()