Library is bit cleaner now

.gitignore

@@ -42,3 +42,5 @@ README.html
 foreign/c/primitives/chibi/foreign-c.c
 *.pdf
 .*
+foreign/c.c
+*.tmp

Makefile

@@ -19,6 +19,7 @@ MITLIBDIR=$(shell echo "(display (->namestring (system-library-directory-pathnam
 
 
 build:
+	rm -rf *.tgz
 	echo "<pre>$$(cat README.md)</pre>" > README.html
 	snow-chibi package \
 		--version=${VERSION} \
@@ -26,17 +27,7 @@ build:
 		--doc=README.html \
 		--foreign-depends=ffi \
 		--description="Portable foreign function interface for R7RS Schemes" \
-		--test=test.scm \
+	foreign/c.sld
-	foreign/c.sld \
-	foreign/c/array.sld \
-	foreign/c/struct.sld \
-	foreign/c/chibi-primitives.sld \
-	foreign/c/chicken-primitives.sld \
-	foreign/c/guile-primitives.sld \
-	foreign/c/mosh-primitives.sld \
-	foreign/c/racket-primitives.sld \
-	foreign/c/sagittarius-primitives.sld \
-	foreign/c/ypsilon-primitives.sld
 
 build-gauche:
 	snow-chibi package \
@@ -48,7 +39,7 @@ build-gauche:
 	foreign/c/gauche-primitives.stub
 
 install:
-	snow-chibi --impls=${SCHEME} ${SNOW_CHIBI_ARGS} install ${PKG}
+	snow-chibi --impls=${SCHEME} --always-yes install ${PKG}
 
 install-gauche:
 	if [ "${SCHEME}" = "gauche" ]; then \
@@ -70,9 +61,6 @@ test: libtest.o libtest.so libtest.a
 		COMPILE_R7RS=${SCHEME} compile-r7rs -I . -o test test.scm
 	LD_LIBRARY_PATH=. ./test
 
-test-no: package libtest.o libtest.so libtest.a
-	COMPILE_R7RS=${SCHEME} test-snowball --apt-pkgs "libffi-dev" ${PKG}
-
 test-docker:
 	docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=retropikzel-foreign-c-test-${SCHEME} -f Dockerfile.test .
 	docker run -v "${PWD}:/workdir" -w /workdir -t retropikzel-foreign-c-test-${SCHEME} sh -c "make SCHEME=${SCHEME} SNOW_CHIBI_ARGS=--always-yes build install test"

foreign/c.scm

@@ -190,7 +190,7 @@
     (define libc-name "ucrtbase"))
   (else
     (define libc-name
-      (cond ((get-environment-variable "BE_HOST_CPU") "root") ; Haiku
+      (cond ;((get-environment-variable "BE_HOST_CPU") "root") ; Haiku
             (else "c")))))
 
 
@@ -315,7 +315,7 @@
   (kawa
     (define c-null?
       (lambda (pointer)
-        (invoke pointer 'equals null-pointer))))
+        (invoke pointer 'equals (make-c-null)))))
   ;; FIXME
   (chibi #t) ;; In chibi-primitives.stub
   (gauche (define c-null? pointer-null?))

foreign/c.sld

@@ -8,22 +8,24 @@
           (scheme inexact))
   (cond-expand
     (chibi (import (foreign c chibi-primitives)))
-    (chicken (import ;(chicken memory) ;; FIXME
+    (chicken (import (foreign c chicken-primitives)))
-                     (foreign c chicken-primitives)))
     ;(cyclone (import (foreign c cyclone-primitives)))
     ;(gambit (import (foreign c gambit-primitives)))
     ;(gauche (import (foreign c gauche-primitives)))
     (guile (import (foreign c guile-primitives)))
-    ;(kawa (import (foreign c kawa-primitives)))
+    (kawa (import (foreign c kawa-primitives)))
     ;(mit-scheme (import (foreign c mit-scheme-primitives)))
     ;(larceny (import (foreign c larceny-primitives)))
     (mosh (import (foreign c mosh-primitives)))
     (racket (import (foreign c racket-primitives)))
     (sagittarius (import (foreign c sagittarius-primitives)))
     (stklos (import (foreign c stklos-primitives))
-            ;; FIXME
             (export foreign-c:string-split))
-    ;(ypsilon (import (foreign c ypsilon-primitives)) (export int))
+    (ypsilon (import (foreign c ypsilon-primitives))
+             (export c-function
+                     c-callback
+                     bytevector-c-int8-set!
+                     bytevector-c-uint8-ref))
     )
   (export ;;;; Primitives 1
           c-type-size

foreign/c/chibi-primitives.scm

@@ -14,7 +14,7 @@
           ((equal? type 'unsigned-short) (c-bytevector-sint-ref pointer offset (native-endianness) (size-of-type 'unsigned-short)))
           ((equal? type 'int) (c-bytevector-sint-ref pointer offset (native-endianness) (size-of-type 'int)))
           ((equal? type 'unsigned-int) (c-bytevector-sint-ref pointer offset (native-endianness) (size-of-type 'unsigned-int)))
-          ((equal? type 'long) (c-bytevector-sint-ref pointer offset (native-endianness) (sife-of-type 'long)))
+          ((equal? type 'long) (c-bytevector-sint-ref pointer offset (native-endianness) (size-of-type 'long)))
           ((equal? type 'unsigned-long) (c-bytevector-sint-ref pointer offset (native-endianness) (size-of-type 'unsigned-long)))
           ((equal? type 'float) (c-bytevector-ieee-single-native-ref pointer offset))
           ((equal? type 'double) (c-bytevector-ieee-double-native-ref pointer offset))
@@ -104,7 +104,8 @@
 (define shared-object-load
   (lambda (path options)
     (let ((shared-object (dlopen path RTLD-NOW))
-          (maybe-error (dlerror)))
+          ;(maybe-error (dlerror))
+          )
       shared-object)))
 
 (define c-bytevector?
@@ -142,9 +143,10 @@
 
 (define make-c-function
   (lambda (shared-object c-name return-type argument-types)
-    (dlerror) ;; Clean all previous errors
+    ;(dlerror) ;; Clean all previous errors
     (let ((c-function (dlsym shared-object c-name))
-          (maybe-dlerror (dlerror)))
+          ;(maybe-dlerror (dlerror))
+          )
       (lambda arguments
         (let* ((return-pointer
                  (internal-ffi-call (length argument-types)

foreign/c/cyclone-primitives.scm

@@ -93,6 +93,9 @@
           ((equal? type 'double) (c-value "sizeof(double)" int))
           ((equal? type 'pointer) (c-value "sizeof(void*)" int)))))
 
+;; FIXME
+(define align-of-type size-of-type)
+
 (define-c pointer-address
           "(void *data, int argc, closure _, object k, object pointer)"
           "make_c_opaque(opq, &(void*)opaque_ptr(pointer));
@@ -226,13 +229,13 @@
           *p = double_value(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pointer-pointer-set!
+(define-c c-bytevector-pointer-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "uintptr_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = (uintptr_t)&opaque_ptr(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define pointer-set!
+#;(define pointer-set!
   (lambda (pointer type offset value)
     (cond
       ((equal? type 'int8) (pointer-int8-set! pointer offset value))
@@ -341,15 +344,15 @@
           alloca_double(d, *p);
           return_closcall1(data, k, d);")
 
-(define-c pointer-pointer-get
+(define-c c-bytevector-pointer-ref
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "make_c_opaque(opq, (void*)opaque_ptr(pointer) + obj_obj2int(offset));
           return_closcall1(data, k, &opq);")
 
-#;(define c-bytevector-u8-set! pointer-uint8-set!)
+(define c-bytevector-u8-set! pointer-uint8-set!)
 (define c-bytevector-u8-ref pointer-uint8-get)
 
-(define pointer-get
+#;(define pointer-get
   (lambda (pointer type offset)
     (cond
       ((equal? type 'int8) (pointer-int8-get pointer offset))

foreign/c/cyclone-primitives.sld

@@ -7,7 +7,7 @@
           (scheme inexact)
           (scheme process-context)
           (cyclone foreign)
-          (scheme cyclone primitives)))
+          (scheme cyclone primitives))
   (export size-of-type
           align-of-type
           shared-object-load
@@ -18,4 +18,4 @@
           c-bytevector-u8-set!
           c-bytevector-pointer-ref
           c-bytevector-pointer-set!)
-  (include "primitives-cyclone.scm"))
+  (include "cyclone-primitives.scm"))

foreign/c/gauche-primitives.scm

@@ -0,0 +1,26 @@
+
+;;;; This file is dependent on content of other files added trough (include...)
+;;;; And that's why it is separated
+
+(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)))
+      (lambda arguments
+        (let ((return-pointer (internal-ffi-call (length argument-types)
+                                                 (type->libffi-type-number return-type)
+                                                 (map type->libffi-type-number argument-types)
+                                                 c-function
+                                                 (size-of-type return-type)
+                                                 arguments)))
+          (c-bytevector-get return-pointer return-type 0))))))
+
+(define-syntax define-c-procedure
+  (syntax-rules ()
+    ((_ scheme-name shared-object c-name return-type argument-types)
+     (define scheme-name
+       (make-c-function shared-object
+                        (symbol->string c-name)
+                        return-type
+                        argument-types)))))

foreign/c/kawa-primitives.scm

@@ -155,7 +155,6 @@
       (list (cons 'linker linker)
             (cons 'lookup lookup)))))
 
-(define null-pointer (make-c-null))
 (define u8-value-layout
   (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE)
           'withByteAlignment