Gauche and Chibi can now pass strings to foreign functions
This commit is contained in:
parent
a6e63db252
commit
bbbfab1723
8
Makefile
8
Makefile
|
|
@ -14,9 +14,13 @@ chibi:
|
|||
-shared
|
||||
|
||||
gauche:
|
||||
CFLAGS="-I. -Werror -Wall -g3 -lffi" \
|
||||
gauche-package compile \
|
||||
--verbose --srcdir=src/gauche retropikzel-pffi-gauche pffi.c gauchelib.scm
|
||||
--verbose \
|
||||
--srcdir=src/gauche \
|
||||
--cc=${CC} \
|
||||
--cflags="-I." \
|
||||
--libs=-lffi \
|
||||
retropikzel-pffi-gauche pffi.c gauchelib.scm
|
||||
|
||||
jenkinsfile:
|
||||
gosh -r7 -I ./snow build.scm
|
||||
|
|
|
|||
|
|
@ -140,37 +140,33 @@
|
|||
|
||||
(define pffi-type->libffi-type
|
||||
(lambda (type)
|
||||
(cond
|
||||
((equal? type 'int8_t) (get-ffi-type-int8))
|
||||
((equal? type 'uint8_t) (get-ffi-type-uint8))
|
||||
((equal? type 'int16_t) (get-ffi-type-int16))
|
||||
((equal? type 'uint16_t) (get-ffi-type-uint16))
|
||||
((equal? type 'int32_t) (get-ffi-type-int32))
|
||||
((equal? type 'uint32_t) (get-ffi-type-uint32))
|
||||
((equal? type 'int64_t) (get-ffi-type-int64))
|
||||
((equal? type 'uint64_t) (get-ffi-type-uint64))
|
||||
((equal? type 'char) (get-ffi-type-char))
|
||||
((equal? type 'unsigned-char) (get-ffi-type-uchar))
|
||||
((equal? type 'bool) (get-ffi-type-int8))
|
||||
((equal? type 'short) (get-ffi-type-short))
|
||||
((equal? type 'unsigned-short) (get-ffi-type-ushort))
|
||||
((equal? type 'int) (get-ffi-type-int))
|
||||
((equal? type 'unsigned-int) (get-ffi-type-uint))
|
||||
((equal? type 'long) (get-ffi-type-long))
|
||||
((equal? type 'unsigned-long) (get-ffi-type-ulong))
|
||||
((equal? type 'float) (get-ffi-type-float))
|
||||
((equal? type 'double) (get-ffi-type-double))
|
||||
((equal? type 'void) (get-ffi-type-void))
|
||||
((equal? type 'pointer) (get-ffi-type-pointer))
|
||||
((equal? type 'callback) (get-ffi-type-pointer))
|
||||
)))
|
||||
(cond ((equal? type 'int8_t) (get-ffi-type-int8))
|
||||
((equal? type 'uint8_t) (get-ffi-type-uint8))
|
||||
((equal? type 'int16_t) (get-ffi-type-int16))
|
||||
((equal? type 'uint16_t) (get-ffi-type-uint16))
|
||||
((equal? type 'int32_t) (get-ffi-type-int32))
|
||||
((equal? type 'uint32_t) (get-ffi-type-uint32))
|
||||
((equal? type 'int64_t) (get-ffi-type-int64))
|
||||
((equal? type 'uint64_t) (get-ffi-type-uint64))
|
||||
((equal? type 'char) (get-ffi-type-char))
|
||||
((equal? type 'unsigned-char) (get-ffi-type-uchar))
|
||||
((equal? type 'bool) (get-ffi-type-int8))
|
||||
((equal? type 'short) (get-ffi-type-short))
|
||||
((equal? type 'unsigned-short) (get-ffi-type-ushort))
|
||||
((equal? type 'int) (get-ffi-type-int))
|
||||
((equal? type 'unsigned-int) (get-ffi-type-uint))
|
||||
((equal? type 'long) (get-ffi-type-long))
|
||||
((equal? type 'unsigned-long) (get-ffi-type-ulong))
|
||||
((equal? type 'float) (get-ffi-type-float))
|
||||
((equal? type 'double) (get-ffi-type-double))
|
||||
((equal? type 'void) (get-ffi-type-void))
|
||||
((equal? type 'pointer) (get-ffi-type-pointer))
|
||||
((equal? type 'callback) (get-ffi-type-pointer)))))
|
||||
|
||||
(define argument->pointer
|
||||
(lambda (value type)
|
||||
(cond ((pffi-pointer? value)
|
||||
value)
|
||||
((procedure? value)
|
||||
(scheme-procedure-to-pointer value))
|
||||
(cond ((pffi-pointer? value) value)
|
||||
((procedure? value) (scheme-procedure-to-pointer value))
|
||||
(else (let ((pointer (pffi-pointer-allocate (size-of-type type))))
|
||||
(pffi-pointer-set! pointer type 0 value)
|
||||
pointer)))))
|
||||
|
|
@ -179,24 +175,24 @@
|
|||
(lambda (shared-object c-name return-type argument-types)
|
||||
(dlerror) ;; Clean all previous errors
|
||||
(let ((c-function (dlsym shared-object c-name))
|
||||
(maybe-dlerror (dlerror))
|
||||
(return-value (pffi-pointer-allocate
|
||||
(if (equal? return-type 'void)
|
||||
0
|
||||
(size-of-type return-type)))))
|
||||
(maybe-dlerror (dlerror)))
|
||||
(when (not (pffi-pointer-null? maybe-dlerror))
|
||||
(error (pffi-pointer->string maybe-dlerror)))
|
||||
(lambda arguments
|
||||
(internal-ffi-call (length argument-types)
|
||||
(pffi-type->libffi-type return-type)
|
||||
(map pffi-type->libffi-type argument-types)
|
||||
c-function
|
||||
return-value
|
||||
(map argument->pointer
|
||||
arguments
|
||||
argument-types))
|
||||
(cond ((not (equal? return-type 'void))
|
||||
(pffi-pointer-get return-value return-type 0)))))))
|
||||
(let ((return-value (pffi-pointer-allocate
|
||||
(if (equal? return-type 'void)
|
||||
0
|
||||
(size-of-type return-type)))))
|
||||
(internal-ffi-call (length argument-types)
|
||||
(pffi-type->libffi-type return-type)
|
||||
(map pffi-type->libffi-type argument-types)
|
||||
c-function
|
||||
return-value
|
||||
(map argument->pointer
|
||||
arguments
|
||||
argument-types))
|
||||
(cond ((not (equal? return-type 'void))
|
||||
(pffi-pointer-get return-value return-type 0))))))))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
|
|
|
|||
|
|
@ -9,7 +9,8 @@
|
|||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string))
|
||||
pffi-pointer->string
|
||||
pffi-define))
|
||||
(select-module retropikzel.pffi.gauche)
|
||||
(dynamic-load "retropikzel-pffi-gauche")
|
||||
|
||||
|
|
@ -114,31 +115,71 @@
|
|||
(lambda (pointer)
|
||||
(pointer->string pointer)))
|
||||
|
||||
(define pffi-type->libffi-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) (get-ffi-type-int8))
|
||||
((equal? type 'uint8) (get-ffi-type-uint8))
|
||||
((equal? type 'int16) (get-ffi-type-int16))
|
||||
((equal? type 'uint16) (get-ffi-type-uint16))
|
||||
((equal? type 'int32) (get-ffi-type-int32))
|
||||
((equal? type 'uint32) (get-ffi-type-uint32))
|
||||
((equal? type 'int64) (get-ffi-type-int64))
|
||||
((equal? type 'uint64) (get-ffi-type-uint64))
|
||||
((equal? type 'char) (get-ffi-type-char))
|
||||
((equal? type 'unsigned-char) (get-ffi-type-uchar))
|
||||
((equal? type 'bool) (get-ffi-type-int8))
|
||||
((equal? type 'short) (get-ffi-type-short))
|
||||
((equal? type 'unsigned-short) (get-ffi-type-ushort))
|
||||
((equal? type 'int) (get-ffi-type-int))
|
||||
((equal? type 'unsigned-int) (get-ffi-type-uint))
|
||||
((equal? type 'long) (get-ffi-type-long))
|
||||
((equal? type 'unsigned-long) (get-ffi-type-ulong))
|
||||
((equal? type 'float) (get-ffi-type-float))
|
||||
((equal? type 'double) (get-ffi-type-double))
|
||||
((equal? type 'void) (get-ffi-type-void))
|
||||
((equal? type 'pointer) (get-ffi-type-pointer))
|
||||
((equal? type 'callback) (get-ffi-type-pointer)))))
|
||||
|
||||
(define argument->pointer
|
||||
(lambda (value type)
|
||||
(cond ((pffi-pointer? value) value)
|
||||
((procedure? value) (scheme-procedure-to-pointer value))
|
||||
(else (let ((pointer (pffi-pointer-allocate (size-of-type type))))
|
||||
(pffi-pointer-set! pointer type 0 value)
|
||||
pointer)))))
|
||||
|
||||
(define make-c-function
|
||||
(lambda (shared-object c-name return-type argument-types)
|
||||
(dlerror) ;; Clean all previous errors
|
||||
(let ((c-function (dlsym shared-object c-name))
|
||||
(maybe-dlerror (dlerror))
|
||||
(return-value (pffi-pointer-allocate
|
||||
(if (equal? return-type 'void)
|
||||
0
|
||||
(size-of-type return-type)))))
|
||||
(maybe-dlerror (dlerror)))
|
||||
(when (not (pffi-pointer-null? maybe-dlerror))
|
||||
(error (pffi-pointer->string maybe-dlerror)))
|
||||
(lambda arguments
|
||||
(internal-ffi-call (length argument-types)
|
||||
(pffi-type->libffi-type return-type)
|
||||
(map pffi-type->libffi-type argument-types)
|
||||
c-function
|
||||
return-value
|
||||
(map argument->pointer
|
||||
arguments
|
||||
argument-types))
|
||||
(cond ((not (equal? return-type 'void))
|
||||
(pffi-pointer-get return-value return-type 0)))))))
|
||||
(let ((return-value (pffi-pointer-allocate
|
||||
(if (equal? return-type 'void)
|
||||
0
|
||||
(size-of-type return-type)))))
|
||||
(internal-ffi-call (length argument-types)
|
||||
(pffi-type->libffi-type return-type)
|
||||
(map pffi-type->libffi-type argument-types)
|
||||
c-function
|
||||
return-value
|
||||
(map argument->pointer
|
||||
arguments
|
||||
argument-types))
|
||||
(cond ((not (equal? return-type 'void))
|
||||
(display "Return value pointer: ")
|
||||
(write return-value)
|
||||
(newline)
|
||||
(pffi-pointer-get return-value return-type 0))))))))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-c-function shared-object c-name return-type argument-types)))))
|
||||
(make-c-function shared-object
|
||||
(symbol->string c-name)
|
||||
return-type
|
||||
argument-types)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -75,5 +75,24 @@
|
|||
(define-cproc dlerror () pffi_dlerror)
|
||||
(define-cproc dlsym (shared-object c-name) pffi_dlsym)
|
||||
(define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call)
|
||||
;(define-cproc make-c-function (shared-object c-name return-type argument-types) make_c_function)
|
||||
|
||||
(define-cproc get-ffi-type-int8 () get_ffi_type_int8)
|
||||
(define-cproc get-ffi-type-uint8 () get_ffi_type_uint8)
|
||||
(define-cproc get-ffi-type-int16 () get_ffi_type_int16)
|
||||
(define-cproc get-ffi-type-uint16 () get_ffi_type_uint16)
|
||||
(define-cproc get-ffi-type-int32 () get_ffi_type_int32)
|
||||
(define-cproc get-ffi-type-uint32 () get_ffi_type_uint32)
|
||||
(define-cproc get-ffi-type-int64 () get_ffi_type_int64)
|
||||
(define-cproc get-ffi-type-uint64 () get_ffi_type_uint64)
|
||||
(define-cproc get-ffi-type-char () get_ffi_type_char)
|
||||
(define-cproc get-ffi-type-unsigned-char () get_ffi_type_unsigned_char)
|
||||
(define-cproc get-ffi-type-short () get_ffi_type_short)
|
||||
(define-cproc get-ffi-type-unsigned-short () get_ffi_type_unsigned_short)
|
||||
(define-cproc get-ffi-type-int () get_ffi_type_int)
|
||||
(define-cproc get-ffi-type-unsigned-int () get_ffi_type_unsigned_int)
|
||||
(define-cproc get-ffi-type-long () get_ffi_type_long)
|
||||
(define-cproc get-ffi-type-unsigned-long () get_ffi_type_unsigned_long)
|
||||
(define-cproc get-ffi-type-float () get_ffi_type_float)
|
||||
(define-cproc get-ffi-type-double () get_ffi_type_double)
|
||||
(define-cproc get-ffi-type-pointer () get_ffi_type_pointer)
|
||||
)
|
||||
|
|
|
|||
12
test.scm
12
test.scm
|
|
@ -642,8 +642,16 @@
|
|||
(print-header 'pffi-define)
|
||||
|
||||
(pffi-define c-puts libc-stdlib 'puts 'int (list 'pointer))
|
||||
(define chars-written (c-puts (pffi-string->pointer "Hello from testing, I am C function puts")))
|
||||
(assert = chars-written 41)
|
||||
(debug c-puts)
|
||||
(define chars-written (c-puts (pffi-string->pointer "puts: Hello from testing, I am C function puts")))
|
||||
(debug chars-written)
|
||||
(assert = chars-written 47)
|
||||
|
||||
(pffi-define c-abs libc-stdlib 'abs 'int (list 'int))
|
||||
(debug c-abs)
|
||||
(define absoluted (c-abs -2))
|
||||
(debug absoluted)
|
||||
(assert = absoluted 2)
|
||||
|
||||
(pffi-define c-atoi libc-stdlib 'atoi 'int (list 'pointer))
|
||||
(assert = (c-atoi (pffi-string->pointer "100")) 100)
|
||||
|
|
|
|||
Loading…
Reference in New Issue