diff --git a/Makefile b/Makefile index cbeff94..0ccd4d3 100644 --- a/Makefile +++ b/Makefile @@ -1,10 +1,10 @@ -.PHONY=libtest.o libtest.so libtest.a documentation +.PHONY=libtest.o tests/libtest.so libtest.a documentation CC=gcc DOCKER=docker run -it -v ${PWD}:/workdir DOCKER_INIT=cd /workdir && make clean && VERSION=$(shell grep "version:" README.md | awk '{split\($0,a\); print a[2];}') -all: chibi gauche libtest.so libtest.o libtest.a +all: chibi gauche tests/libtest.so libtest.o libtest.a # apt-get install pandoc weasyprint docs: @@ -42,27 +42,30 @@ jenkinsfile: libtest.o: src/libtest.c ${CC} -o libtest.o -fPIC -c src/libtest.c -I./include -libtest.so: src/libtest.c - ${CC} -o libtest.so -shared -fPIC src/libtest.c -I./include +tests/libtest.so: src/libtest.c + ${CC} -o tests/libtest.so -shared -fPIC src/libtest.c -I./include libtest.a: libtest.o src/libtest.c ar rcs libtest.a libtest.o -test-interpreter-compliance: libtest.so +test-interpreter-compliance: tests/libtest.so SCHEME=${SCHEME} script-r7rs -I . tests/compliance.scm test-interpreter-compliance-docker: docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} script-r7rs -I . tests/compliance.scm" -test-compile-library: libtest.so libtest.a libtest.o +test-compile-library: tests/libtest.so libtest.a libtest.o SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld -test-compiler-compliance: test-compile-library - SCHEME=${SCHEME} CFLAGS="-I./include -L." LDFLAGS="-ltest libtest.o" compile-r7rs -I . tests/compliance.scm +test-compiler-compliance-compile: test-compile-library + SCHEME=${SCHEME} CFLAGS="-I../include -L.." LDFLAGS="-ltest" compile-r7rs -I . tests/compliance.scm ./tests/compliance -test-compiler-compliance-docker: libtest.so libtest.a +test-compiler-compliance: test-compiler-compliance-compile + ./tests/compliance + +test-compiler-compliance-docker: tests/libtest.so libtest.a docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld" docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs -I . compliance.scm && ./test" diff --git a/include/libtest.h b/include/libtest.h index 86e229d..3a42d3b 100644 --- a/include/libtest.h +++ b/include/libtest.h @@ -13,3 +13,5 @@ int color_check_by_value(struct color color); int test_check(struct test* test); int test_check_by_value(struct test test); struct test* test_new(); +void takes_no_args(); +int takes_no_args_returns_int(); diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index 6b5d4f1..bf677f1 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -140,23 +140,23 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load - ;pffi-pointer-null - ;pffi-pointer-null? - ;pffi-pointer-allocate - ;pffi-pointer-address - ;pffi-pointer? - ;pffi-pointer-free - ;pffi-pointer-set! - ;pffi-pointer-get - ;pffi-string->pointer - ;pffi-pointer->string + pffi-define-library + pffi-pointer-null + pffi-pointer-null? + pffi-pointer-allocate + pffi-pointer-address + pffi-pointer? + pffi-pointer-free + pffi-pointer-set! + pffi-pointer-get + pffi-string->pointer + pffi-pointer->string pffi-struct-make pffi-struct-pointer pffi-struct-offset-get pffi-struct-get pffi-struct-set! - ;pffi-define + pffi-define ;pffi-define-callback )) (gauche @@ -540,4 +540,5 @@ (ypsilon (include "pffi/ypsilon.scm"))) (include "pffi/shared/struct.scm") (include "pffi/shared/union.scm") - (include "pffi/shared/main.scm")) + (include "pffi/shared/main.scm") + ) diff --git a/retropikzel/pffi/gambit.scm b/retropikzel/pffi/gambit.scm index 54dfb88..f6b9f84 100644 --- a/retropikzel/pffi/gambit.scm +++ b/retropikzel/pffi/gambit.scm @@ -1,5 +1,11 @@ +(c-declare "#include ") (c-declare "#include ") +(define-macro + (pffi-init) + `(begin (c-define-type pointer (pointer void)) + (c-define-type callback (pointer void)))) + (define size-of-int8_t (c-lambda () int "___return(sizeof(int8_t));")) (define size-of-uint8_t (c-lambda () int "___return(sizeof(uint8_t));")) (define size-of-int16_t (c-lambda () int "___return(sizeof(int16_t));")) @@ -45,19 +51,157 @@ ((eq? type 'void) (size-of-void*)) (else (error "Can not get size of unknown type" type))))) -#;(define-macro - (include-c-headers headers) - `(c-declare ,(apply string-append - (map - (lambda (header) - (string-append "#include <" header ">" (string #\newline))) - (list "stdio.h"))))) +(define-macro + (pffi-define-library name headers object-name . options) + `(begin (define ,name #t) + (c-declare ,(apply string-append + (map + (lambda (header) + (string-append "#include <" header ">" (string #\newline))) + (cdr headers)))))) + +(define pointer? (c-lambda ((pointer void)) bool "___return(1);")) +(define pffi-pointer? + (lambda (object) + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (x) #f) + (lambda () (pointer? object))))))) + +(define pffi-pointer-null (c-lambda () (pointer void) "void* p = NULL; ___return(p);")) + +(define pointer-null? (c-lambda ((pointer void)) bool "if(___arg1 == NULL) { ___return(1); } else { ___return(0); }")) +(define pffi-pointer-null? + (lambda (pointer) + (and (pffi-pointer? pointer) + (pointer-null? pointer)))) + +(define pffi-pointer-allocate (c-lambda (int) (pointer void) "void* p = malloc(___arg1); ___return(p);")) + +(define pffi-pointer-address (c-lambda ((pointer void)) ptrdiff_t "void* p = ___arg1; ___return((intptr_t)&p);")) + +(define pffi-pointer-free (c-lambda ((pointer void)) void "free(___arg1);")) + +(define pointer-set-c-int8_t! (c-lambda ((pointer void) int int8) void "*(int8_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-uint8_t! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-int16_t! (c-lambda ((pointer void) int int16) void "*(int16_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-uint16_t! (c-lambda ((pointer void) int unsigned-int16) void "*(uint16_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-int32_t! (c-lambda ((pointer void) int int32) void "*(int32_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-uint32_t! (c-lambda ((pointer void) int unsigned-int32) void "*(uint32_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-int64_t! (c-lambda ((pointer void) int int64) void "*(int64_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-uint64_t! (c-lambda ((pointer void) int unsigned-int64) void "*(uint64_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-char! (c-lambda ((pointer void) int char) void "*((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-short! (c-lambda ((pointer void) int short) void "*(short*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-unsigned-short! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned short*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-int! (c-lambda ((pointer void) int int) void "*(int*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-unsigned-int! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned int*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-long! (c-lambda ((pointer void) int long) void "*(long*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-unsigned-long! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned long*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-float! (c-lambda ((pointer void) int float) void "*(float*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-double! (c-lambda ((pointer void) int double) void "*(double*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-pointer! (c-lambda ((pointer void) int (pointer void)) void "{ char* p = (char*)___arg1 + ___arg2; *(char**)p = ___arg3; }")) + +(define pffi-pointer-set! + (lambda (pointer type offset value) + (cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value)) + ((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value)) + ((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value)) + ((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value)) + ((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value)) + ((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value)) + ((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value)) + ((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value)) + ((equal? type 'char) (pointer-set-c-char! pointer offset value)) + ((equal? type 'short) (pointer-set-c-short! pointer offset value)) + ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value)) + ((equal? type 'int) (pointer-set-c-int! pointer offset value)) + ((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value)) + ((equal? type 'long) (pointer-set-c-long! pointer offset value)) + ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value)) + ((equal? type 'float) (pointer-set-c-float! pointer offset value)) + ((equal? type 'double) (pointer-set-c-double! pointer offset value)) + ((equal? type 'void) (pointer-set-c-pointer! pointer offset value)) + ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value))))) + +(define pointer-ref-c-int8_t (c-lambda ((pointer void) int) int8 "___return(*(int8_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-uint8_t (c-lambda ((pointer void) int) unsigned-int8 "___return(*(uint8_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-int16_t (c-lambda ((pointer void) int) int16 "___return(*(int16_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-uint16_t (c-lambda ((pointer void) int) unsigned-int16 "___return(*(uint16_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-int32_t (c-lambda ((pointer void) int) int32 "___return(*(int32_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-uint32_t (c-lambda ((pointer void) int) unsigned-int32 "___return(*(uint32_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-int64_t (c-lambda ((pointer void) int) int64 "___return(*(int64_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-uint64_t (c-lambda ((pointer void) int) unsigned-int64 "___return(*(uint64_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-char (c-lambda ((pointer void) int) char "___return(*((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-short (c-lambda ((pointer void) int) short "___return(*(short*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-unsigned-short (c-lambda ((pointer void) int) unsigned-short "___return(*(unsigned short*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-int (c-lambda ((pointer void) int) int "___return(*(int*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-unsigned-int (c-lambda ((pointer void) int) unsigned-int "___return(*(unsigned int*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-long (c-lambda ((pointer void) int) long "___return(*(long*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-unsigned-long (c-lambda ((pointer void) int) unsigned-long "___return(*(unsigned long*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-float (c-lambda ((pointer void) int) float "___return(*(float*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-double (c-lambda ((pointer void) int) double "___return(*(double*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-pointer (c-lambda ((pointer void) int) (pointer void) " char* p = (char*)___arg1 + ___arg2; ___return(*(char**)p);")) + + +(define pffi-pointer-get + (lambda (pointer type offset) + (cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset)) + ((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset)) + ((equal? type 'int16) (pointer-ref-c-int16_t pointer offset)) + ((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset)) + ((equal? type 'int32) (pointer-ref-c-int32_t pointer offset)) + ((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset)) + ((equal? type 'int64) (pointer-ref-c-int64_t pointer offset)) + ((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset)) + ((equal? type 'char) (pointer-ref-c-char pointer offset)) + ((equal? type 'short) (pointer-ref-c-short pointer offset)) + ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset)) + ((equal? type 'int) (pointer-ref-c-int pointer offset)) + ((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset)) + ((equal? type 'long) (pointer-ref-c-long pointer offset)) + ((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset)) + ((equal? type 'float) (pointer-ref-c-float pointer offset)) + ((equal? type 'double) (pointer-ref-c-double pointer offset)) + ((equal? type 'void) (pointer-ref-c-pointer pointer offset)) + ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) (define-macro - (pffi-shared-object-auto-load headers object-name . options) - `(c-declare ,(apply string-append - (map - (lambda (header) - (string-append "#include <" header ">" (string #\newline))) - (cdr headers))))) - + (pffi-define scheme-name shared-object c-name return-type argument-types) + (display "HERE: ") + (write argument-types) + (newline) + (write (equal? '(list) argument-types)) + (newline) + (letrec* ((native-argument-types + (if (equal? '(list) argument-types) + (list) + (let ((types (map cdr (cdr argument-types)))) + (if (null? types) types (map car types))))) + (native-return-type (car (cdr return-type))) + (c-arguments (lambda (index argument-count result) + (if (> index argument-count) + result + (c-arguments (+ index 1) + argument-count + (string-append result + "___arg" + (number->string index) + (if (< index argument-count) + ", " + "")))))) + (c-code (string-append + (if (equal? 'void (cadr return-type)) "" "___return(") + (symbol->string (cadr c-name)) + "(" (c-arguments 1 (- (length argument-types) 1) "") ")" + (if (equal? 'void (cadr return-type)) "" ")") + ";"))) + (write `(define ,scheme-name + (c-lambda ,native-argument-types + ,native-return-type + ,c-code))) + (newline) + `(define ,scheme-name + (c-lambda ,native-argument-types + ,native-return-type + ,c-code)))) diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index af4a15f..00f772d 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/retropikzel/pffi/shared/main.scm @@ -6,8 +6,8 @@ '(import (chicken foreign) (chicken memory)) #t)))) - (else - (define pffi-init(lambda () #t)))) + (gambit #t) + (else (define pffi-init (lambda () #t)))) (define pffi-type? (lambda (object) @@ -89,12 +89,12 @@ (cond-expand (gambit #t) ((or chicken cyclone) - (define-syntax pffi-load + (define-syntax pffi-define-library (syntax-rules () ((_ headers object-name . options) (pffi-shared-object-load headers))))) (else - (define pffi-load + (define pffi-define-library (lambda (headers object-name . options) (let* ((additional-paths (if (assoc 'additional-paths options) (cdr (assoc 'additional-paths options)) diff --git a/src/libtest.c b/src/libtest.c index 99f0213..75c3703 100644 --- a/src/libtest.c +++ b/src/libtest.c @@ -273,3 +273,11 @@ EXPORT struct test* test_new() { t->n = 14; return t; } + +EXPORT void takes_no_args() { + puts("I take no arguments :)"); +} + +EXPORT int takes_no_args_returns_int() { + return 0; +} diff --git a/tests/compliance.scm b/tests/compliance.scm index 0ccf3d5..6e3cdac 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -28,21 +28,38 @@ (set! assert-tag tag) (set! count 0))) -(define-syntax assert - (syntax-rules () - ((_ check value-a value-b) - (let ((result (apply check (list value-a value-b)))) - (set! count (+ count 1)) - (if (not result) (display "FAIL ") (display "PASS ")) - (display "[") - (display assert-tag) - (display " - ") - (display count) - (display "]") - (display ": ") - (write (list 'check 'value-a 'value-b)) - (newline) - (when (not result) (exit 1)))))) +(cond-expand + (gambit + (define assert + (lambda (check value-a value-b) + (let ((result (apply check (list value-a value-b)))) + (set! count (+ count 1)) + (if (not result) (display "FAIL ") (display "PASS ")) + (display "[") + (display assert-tag) + (display " - ") + (display count) + (display "]") + (display ": ") + (write (list 'check 'value-a 'value-b)) + (newline) + (when (not result) (exit 1)))))) + (else + (define-syntax assert + (syntax-rules () + ((_ check value-a value-b) + (let ((result (apply check (list value-a value-b)))) + (set! count (+ count 1)) + (if (not result) (display "FAIL ") (display "PASS ")) + (display "[") + (display assert-tag) + (display " - ") + (display count) + (display "]") + (display ": ") + (write (list 'check 'value-a 'value-b)) + (newline) + (when (not result) (exit 1)))))))) (define-syntax debug (syntax-rules () @@ -106,8 +123,6 @@ (debug (pffi-type? 'callback)) (assert equal? (pffi-type? 'callback) #t) -(pffi-init) - ;; pffi-size-of (print-header 'pffi-size-of) @@ -384,27 +399,27 @@ (assert equal? (number? align-pointer) #t) (assert = align-pointer 8))) -;; pffi-load +;; pffi-define-library -(print-header 'pffi-load) +(print-header 'pffi-define-library) -(define libc-stdlib - (cond-expand - (windows (pffi-load (list "stdlib.h") "ucrtbase")) - (else (pffi-load (list "stdlib.h") - "c" - '(additional-versions . ("0" "6")))))) +(pffi-define-library libc-stdlib + (list "stdlib.h") + (cond-expand (windows "ucrtbase") (else "c")) + '(additional-versions . ("0" "6"))) (debug libc-stdlib) -(define c-testlib - (cond-expand - (windows (pffi-load (list "libtest.h") - "test" - '(additional-paths . (".")))) - (else (pffi-load (list "libtest.h") +(pffi-define-library libc-stdio + (list "stdio.h") + (cond-expand (windows "ucrtbase") (else "c")) + '(additional-versions . ("0" "6"))) +(debug libc-stdio) + +(pffi-define-library c-testlib + (list "libtest.h") "test" - '(additional-paths . (".")))))) + '(additional-paths . ("."))) (debug c-testlib) @@ -477,12 +492,20 @@ (debug offset) (debug value) -(define-syntax test-type - (syntax-rules () - ((_ type) - (begin - (pffi-pointer-set! set-pointer type offset value) - (assert = (pffi-pointer-get set-pointer type offset) value))))) +(cond-expand + (gambit + (define test-type + (lambda (type) + (begin + (pffi-pointer-set! set-pointer type offset value) + (assert = (pffi-pointer-get set-pointer type offset) value))))) + (else + (define-syntax test-type + (syntax-rules () + ((_ type) + (begin + (pffi-pointer-set! set-pointer type offset value) + (assert = (pffi-pointer-get set-pointer type offset) value))))))) (test-type 'int8) (test-type 'uint8) @@ -656,14 +679,6 @@ (pffi-define c-atoi libc-stdlib 'atoi 'int (list 'pointer)) (assert = (c-atoi (pffi-string->pointer "100")) 100) -(define libc-stdio - (cond-expand - ; FIXME Check that windows so file is correct - (windows (pffi-load (list "stdio.h") "ucrtbase")) - (else (pffi-load (list "stdio.h") - "c" - '(additional-versions . ("0" "6")))))) - (pffi-define c-fopen libc-stdio 'fopen 'pointer (list 'pointer 'pointer)) (define output-file (c-fopen (pffi-string->pointer "testfile.test") (pffi-string->pointer "w"))) @@ -682,6 +697,15 @@ (lambda () (read-line))) "Hello world") #t) +(pffi-define c-takes-no-args c-testlib 'takes_no_args 'void (list)) +(debug c-takes-no-args) +(c-takes-no-args) + +(pffi-define c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int (list)) +(debug c-takes-no-args) +(define takes-no-args-returns-int-result (c-takes-no-args-returns-int)) +(assert equal? (= takes-no-args-returns-int-result 0) #t) + ;; pffi-struct-get (print-header 'pffi-struct-get)