Progress

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
+tests/libtest.so: src/libtest.c
-	${CC} -o libtest.so -shared -fPIC src/libtest.c -I./include
+	${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
+test-compiler-compliance-compile: test-compile-library
-	SCHEME=${SCHEME} CFLAGS="-I./include -L." LDFLAGS="-ltest libtest.o" compile-r7rs -I . tests/compliance.scm
+	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"

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();

retropikzel/pffi.sld

@@ -140,23 +140,23 @@
               pffi-size-of
               pffi-type?
               pffi-align-of
-              pffi-load
+              pffi-define-library
-              ;pffi-pointer-null
+              pffi-pointer-null
-              ;pffi-pointer-null?
+              pffi-pointer-null?
-              ;pffi-pointer-allocate
+              pffi-pointer-allocate
-              ;pffi-pointer-address
+              pffi-pointer-address
-              ;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-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")
+  )

retropikzel/pffi/gambit.scm

@@ -1,5 +1,11 @@
+(c-declare "#include <stdlib.h>")
 (c-declare "#include <stdint.h>")
 
+(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
+(define-macro
-  (include-c-headers headers)
+  (pffi-define-library name headers object-name . options)
-    `(c-declare ,(apply string-append
+  `(begin (define ,name #t)
+          (c-declare ,(apply string-append
                              (map
                                (lambda (header)
                                  (string-append "#include <" header ">" (string #\newline)))
-                         (list "stdio.h")))))
+                               (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)
+  (pffi-define scheme-name shared-object c-name return-type argument-types)
-  `(c-declare ,(apply string-append
+              (display "HERE: ")
-                     (map
+              (write argument-types)
-                       (lambda (header)
+              (newline)
-                         (string-append "#include <" header ">" (string #\newline)))
+              (write (equal? '(list) argument-types))
-                       (cdr headers)))))
+              (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))))

retropikzel/pffi/shared/main.scm

@@ -6,8 +6,8 @@
          '(import (chicken foreign)
                   (chicken memory))
          #t))))
-  (else
+  (gambit #t)
-    (define pffi-init(lambda () #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))

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;
+}

tests/compliance.scm

@@ -28,7 +28,24 @@
     (set! assert-tag tag)
     (set! count 0)))
 
-(define-syntax assert
+(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))))
@@ -42,7 +59,7 @@
            (display ": ")
            (write (list 'check 'value-a 'value-b))
            (newline)
-       (when (not result) (exit 1))))))
+           (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
+(pffi-define-library libc-stdlib
-  (cond-expand
+                     (list "stdlib.h")
-    (windows (pffi-load (list "stdlib.h") "ucrtbase"))
+                     (cond-expand (windows "ucrtbase") (else "c"))
-    (else (pffi-load (list "stdlib.h")
+                     '(additional-versions . ("0" "6")))
-                     "c"
-                     '(additional-versions . ("0" "6"))))))
 
 (debug libc-stdlib)
 
-(define c-testlib
+(pffi-define-library libc-stdio
-  (cond-expand
+                     (list "stdio.h")
-    (windows (pffi-load (list "libtest.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 . (".")))
-    (else (pffi-load (list "libtest.h")
-                     "test"
-                     '(additional-paths . ("."))))))
 
 (debug c-testlib)
 
@@ -477,12 +492,20 @@
 (debug offset)
 (debug value)
 
-(define-syntax test-type
+(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)))))
+           (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)