From bbbfab17230f9be996a67b3c18f6a5644b6a7ede Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 7 Mar 2025 12:14:11 +0200 Subject: [PATCH] Gauche and Chibi can now pass strings to foreign functions --- Makefile | 8 +++- retropikzel/pffi/chibi.scm | 82 ++++++++++++++++++------------------- retropikzel/pffi/gauche.scm | 75 +++++++++++++++++++++++++-------- src/gauche/gauchelib.scm | 21 +++++++++- test.scm | 12 +++++- 5 files changed, 133 insertions(+), 65 deletions(-) diff --git a/Makefile b/Makefile index 3d52d27..da5c856 100644 --- a/Makefile +++ b/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 diff --git a/retropikzel/pffi/chibi.scm b/retropikzel/pffi/chibi.scm index 0d0cbea..410bf72 100644 --- a/retropikzel/pffi/chibi.scm +++ b/retropikzel/pffi/chibi.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 () diff --git a/retropikzel/pffi/gauche.scm b/retropikzel/pffi/gauche.scm index 53b76bc..cfec3ca 100644 --- a/retropikzel/pffi/gauche.scm +++ b/retropikzel/pffi/gauche.scm @@ -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))))) + diff --git a/src/gauche/gauchelib.scm b/src/gauche/gauchelib.scm index 5dbcf68..a3834d3 100644 --- a/src/gauche/gauchelib.scm +++ b/src/gauche/gauchelib.scm @@ -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) ) diff --git a/test.scm b/test.scm index 6e60dc8..9e1967d 100755 --- a/test.scm +++ b/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)