diff --git a/.gitignore b/.gitignore index 253bf6e..d4f52f8 100644 --- a/.gitignore +++ b/.gitignore @@ -13,6 +13,8 @@ import test/import pffi-define test/pffi-define +size-of +test/size-of retropikzel/pffi/*/*.c retropikzel/pffi/*/*.o* retropikzel/pffi/*/*.so diff --git a/Makefile b/Makefile index 558920d..e46967a 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -.PHONY: test/import.scm test/import.scm test/pffi-define.scm +.PHONY: test/import.scm test/import.scm test/pffi-define.scm test/size-of.scm VERSION=v0-1-0 SASH=sash -c -r7 -L . @@ -32,8 +32,8 @@ build-main-chicken: ${CHICKEN} -sJ retropikzel.pffi.${VERSION}.main.scm build-main-gambit: - #${GAMBIT} -obj retropikzel/pffi/${VERSION}/gambit.scm - #${GAMBIT} -obj retropikzel/pffi/${VERSION}/main.sld + ${GAMBIT} -obj retropikzel/pffi/${VERSION}/gambit.scm + ${GAMBIT} -obj retropikzel/pffi/${VERSION}/main.sld #cp retropikzel/pffi/${VERSION}/*.o* test/ build-main-gerbil: @@ -60,24 +60,26 @@ test/import.scm: clean build #${RACKET} $@ ${STKLOS} $@ ${KAWA} $@ - #${CYCLONE} $@ && test/import + ${CYCLONE} $@ && test/import #${GAMBIT} -exe $@ && ./test/import ${CHICKEN} $@ && ./test/import #${GERBIL} $@ +test/import.scm: clean build + ${GAMBIT} -exe $@ && ./test/import + test/pffi-define.scm: clean build ${SASH} $@ ${GUILE} $@ ${KAWA} $@ + ${CHICKEN} -L -lcurl $@ && ./test/pffi-define test/pffi-define.scm: clean build - ${CHICKEN} $@ && ./test/pffi-define + ${CYCLONE} -CLNK -lcurl $@ && test/pffi-define test/size-of.scm: ${SASH} $@ ${GUILE} $@ - #${RACKET} $@ - #${STKLOS} $@ ${KAWA} $@ test/pointer-set-get.scm: diff --git a/guix-chicken-init.sh b/guix-chicken-init.sh new file mode 100644 index 0000000..f97b26a --- /dev/null +++ b/guix-chicken-init.sh @@ -0,0 +1,7 @@ +#!/usr/bin/env bash + +export CHICKEN_INSTALL_REPOSITORY=${HOME}/eggs/lib/chicken/5 +export CHICKEN_REPOSITORY_PATH=${CHICKEN_REPOSITORY_PATH}:${HOME}/eggs/lib/chicken/5 + +chicken-install -init ${HOME}/eggs/lib/chicken/5 +chicken-install r7rs diff --git a/retropikzel/pffi/v0-1-0/chicken.scm b/retropikzel/pffi/v0-1-0/chicken.scm index 446ec01..5b62b8c 100644 --- a/retropikzel/pffi/v0-1-0/chicken.scm +++ b/retropikzel/pffi/v0-1-0/chicken.scm @@ -3,7 +3,9 @@ (import (scheme base) (scheme write) (scheme file) - (scheme process-context)) + (scheme process-context) + (chicken foreign) + (chicken syntax)) (export pffi-shared-object-load pffi-define pffi-size-of @@ -22,16 +24,73 @@ (define pffi-type->native-type (lambda (type) - (error "Not defined"))) + (cond ((equal? type 'int8) 'byte) + ((equal? type 'uint8) 'unsigned-byte) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32) + ((equal? type 'uint32) 'unsigned-int32) + ((equal? type 'int64) 'integer-64) + ((equal? type 'uint64) 'unsigned-integer64) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) 'unsigned-char) + ((equal? type 'short) 'short) + ((equal? type 'unsigned-short) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'unsigned-int) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'unsigned-long) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) 'c-pointer) + ((equal? type 'string) 'c-string) + ((equal? type 'void) 'void) + (else (error "pffi-type->native-type -- No such pffi type" type)))) ) (define pffi-pointer? (lambda (object) (error "Not defined"))) (define-syntax pffi-define - (syntax-rules () - ((pffi-define scheme-name shared-object c-name return-type argument-types) - (error "Not defined")))) + (er-macro-transformer + (lambda (expr rename compare) + (let* ((pffi-type->native-type + (lambda (type) + (cond ((equal? type 'int8) 'byte) + ((equal? type 'uint8) 'unsigned-byte) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32) + ((equal? type 'uint32) 'unsigned-int32) + ((equal? type 'int64) 'integer-64) + ((equal? type 'uint64) 'unsigned-integer64) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) 'unsigned-char) + ((equal? type 'short) 'short) + ((equal? type 'unsigned-short) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'unsigned-int) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'unsigned-long) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) 'c-pointer) + ((equal? type 'string) 'c-string) + ((equal? type 'void) 'void) + (else (error "pffi-type->native-type -- No such pffi type" type))))) + (scheme-name (car (cdr expr))) + (c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr)))))))) + (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr))))))))) + (argument-types + (let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr))))))))) + (if (null? types) + '() + (map pffi-type->native-type (map car (map cdr types))))))) + (if (null? argument-types) + `(define ,scheme-name + (foreign-lambda ,return-type ,c-name)) + `(define ,scheme-name + (foreign-lambda ,return-type ,c-name ,@ argument-types))))))) (define pffi-size-of (lambda (type) @@ -57,9 +116,15 @@ (lambda (pointer size) (error "Not defined"))) - (define pffi-shared-object-load - (lambda (header path) - (error "Not defined"))) + (define-syntax pffi-shared-object-load + (er-macro-transformer + (lambda (expr rename compare) + (let* ((headers (cdr (car (cdr expr))))) + `(begin + ,@ (map + (lambda (header) + `(foreign-declare ,(string-append "#include <" header ">"))) + headers)))))) (define pffi-pointer-free (lambda (pointer) diff --git a/retropikzel/pffi/v0-1-0/cyclone.sld b/retropikzel/pffi/v0-1-0/cyclone.sld index 8e8c299..dc19806 100644 --- a/retropikzel/pffi/v0-1-0/cyclone.sld +++ b/retropikzel/pffi/v0-1-0/cyclone.sld @@ -55,15 +55,44 @@ (define-syntax pffi-define - (syntax-rules () - ((pffi-define msg) - ;(define-c t "(void *data, int argc, closure _, object k, object h)" "puts(string_str(h));") - ;(c-define puts int "puts" string) - (c-code "char* buffer[1000]; fgets(buffer, 1000, stdin); puts(buffer);") - #t - ) - ) - ) + (er-macro-transformer + (lambda (expr rename compare) + (let* ((pffi-type->native-type + (lambda (type) + (cond ((equal? type 'int8) 'byte) + ((equal? type 'uint8) 'unsigned-byte) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32) + ((equal? type 'uint32) 'unsigned-int32) + ((equal? type 'int64) 'integer-64) + ((equal? type 'uint64) 'unsigned-integer64) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) 'unsigned-char) + ((equal? type 'short) 'short) + ((equal? type 'unsigned-short) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'unsigned-int) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'unsigned-long) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) 'c-pointer) + ((equal? type 'string) 'c-string) + ((equal? type 'void) 'void) + (else (error "pffi-type->native-type -- No such pffi type" type))))) + (scheme-name (car (cdr expr))) + (c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr)))))))) + (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr))))))))) + (argument-types + (let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr))))))))) + (if (null? types) + '() + (map pffi-type->native-type (map car (map cdr types))))))) + (if (null? argument-types) + `(c-define ,scheme-name ,return-type ,c-name) + `(c-define ,scheme-name + ,return-type ,c-name ,@ argument-types)))))) (define pffi-size-of @@ -90,12 +119,14 @@ (lambda (pointer size) (error "Not defined"))) -(define-syntax pffi-shared-object-load - (syntax-rules () - ((when headers shared-object additional-paths) - - - ))) + (define-syntax pffi-shared-object-load + (er-macro-transformer + (lambda (expr rename compare) + `(begin + ,@ (map + (lambda (header) + `(include-c-header ,(string-append "<" header ">"))) + (cdr (car (cdr expr)))))))) (define pffi-pointer-free (lambda (pointer) diff --git a/retropikzel/pffi/v0-1-0/main.rkt b/retropikzel/pffi/v0-1-0/main.rkt index b479675..c7edba7 100644 --- a/retropikzel/pffi/v0-1-0/main.rkt +++ b/retropikzel/pffi/v0-1-0/main.rkt @@ -201,6 +201,7 @@ ((pffi-shared-object-auto-load headers object-name additional-paths) (cond-expand (cyclone (pffi-shared-object-load headers object-path)) + (chicken (pffi-shared-object-load headers object-path)) (else (let* ((paths (append auto-load-paths additional-paths)) (shared-object #f)) diff --git a/retropikzel/pffi/v0-1-0/main.scm b/retropikzel/pffi/v0-1-0/main.scm index 251a09c..797eeb6 100644 --- a/retropikzel/pffi/v0-1-0/main.scm +++ b/retropikzel/pffi/v0-1-0/main.scm @@ -200,6 +200,7 @@ ((pffi-shared-object-auto-load headers object-name additional-paths) (cond-expand (cyclone (pffi-shared-object-load headers object-path)) + (chicken (pffi-shared-object-load headers object-path)) (else (let* ((paths (append auto-load-paths additional-paths)) (shared-object #f)) diff --git a/retropikzel/pffi/v0-1-0/main.sld b/retropikzel/pffi/v0-1-0/main.sld index 251a09c..797eeb6 100644 --- a/retropikzel/pffi/v0-1-0/main.sld +++ b/retropikzel/pffi/v0-1-0/main.sld @@ -200,6 +200,7 @@ ((pffi-shared-object-auto-load headers object-name additional-paths) (cond-expand (cyclone (pffi-shared-object-load headers object-path)) + (chicken (pffi-shared-object-load headers object-path)) (else (let* ((paths (append auto-load-paths additional-paths)) (shared-object #f)) diff --git a/retropikzel/pffi/v0-1-0/sagittarius.scm b/retropikzel/pffi/v0-1-0/sagittarius.scm index a08222f..d20d9f2 100644 --- a/retropikzel/pffi/v0-1-0/sagittarius.scm +++ b/retropikzel/pffi/v0-1-0/sagittarius.scm @@ -32,8 +32,6 @@ ((equal? type 'uint32) 'uint32_t) ((equal? type 'int64) 'int64_t) ((equal? type 'uint64) 'uint64_t) - ((equal? type 'intptr) 'intptr_t) - ((equal? type 'uintptr) 'uintptr_t) ((equal? type 'char) 'char) ((equal? type 'unsigned-char) 'char) ((equal? type 'short) 'short) diff --git a/test.scm b/test.scm index 54a211f..6912400 100644 --- a/test.scm +++ b/test.scm @@ -6,10 +6,12 @@ (cyclone foreign)) -(define-syntax while - (syntax-rules () - ((while condition . body) - (let loop () - (cond (condition - (begin . body) - (loop))))))) +(define-syntax pffi-shared-object-load + (er-macro-transformer + (lambda (expr rename compare) + (let* ((headers (cdr (car (cdr expr))))) + `(begin + ,@ (map + (lambda (header) + `(include-c-header ,(string-append "<" header ">"))) + headers)))))) diff --git a/test/pffi-define.scm b/test/pffi-define.scm index 7b6f62e..01c4f18 100644 --- a/test/pffi-define.scm +++ b/test/pffi-define.scm @@ -9,7 +9,7 @@ (display libcurl) (newline) -(pffi-define curl-version libcurl 'curl_version 'string (list)) +(pffi-define 'curl-version libcurl 'curl_version 'string (list)) (display "=================") (newline) diff --git a/test/size-of.scm b/test/size-of.scm index 36d978f..c913751 100644 --- a/test/size-of.scm +++ b/test/size-of.scm @@ -1,6 +1,6 @@ (import (scheme base) (scheme write) - (retropikzel pffi v0.1.0 main)) + (retropikzel pffi v0-1-0 main)) (display 'int8) (display " ")