Move from sourcehut

.build.yml

@@ -1,7 +0,0 @@
-image: alpine/edge
-secrets:
-  - 19cc24de-d15b-4590-b7c3-73fd65d6b24a
-tasks:
-    - trigger-jenkins-build: |
-        branch=$(echo "$GIT_REF" | awk '{split($0,a,"/"); print(a[3])}')
-        curl --netrc-file ${HOME}/netrc-scheme-jenkins -X POST "https://jenkins.scheme.org/job/retropikzel/job/foreign-c/job/${branch}/build?delay=0sec"

.gitignore

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

Dockerfile.test

@@ -1,11 +1,27 @@
+ARG SCHEME=chibi
+ARG IMAGE=${SCHEME}:head
+FROM debian:trixie AS build
+RUN apt-get update && apt-get install -y gcc make git ca-certificates libffi-dev
+WORKDIR /build
+RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1
+RUN git clone https://gitea.scheme.org/Retropikzel/compile-r7rs.git --depth=1
+WORKDIR /build/chibi-scheme
+RUN make
+
 ARG SCHEME=chibi
 ARG IMAGE=${SCHEME}:head
 FROM schemers/${IMAGE}
-COPY --from=retropikzel1/compile-r7rs /opt/compile-r7rs /opt/compile-r7rs
+COPY --from=build /build /build
+WORKDIR /build
+RUN apt-get update && apt-get install -y gcc make libffi-dev
+WORKDIR /build/chibi-scheme
+RUN make install
+RUN mkdir -p ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm
+RUN snow-chibi install --always-yes "(foreign c)"
+RUN snow-chibi install --always-yes "(srfi 170)"
+WORKDIR /build/compile-r7rs
+RUN make build-chibi && make install
 WORKDIR /workdir
 ARG SCHEME=chibi
 ENV COMPILE_R7RS=${SCHEME}
-ENV PATH=/opt/compile-r7rs/bin:${PATH}
-RUN mkdir -p ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm
 RUN snow-chibi install --always-yes --impls=${SCHEME} "(srfi 64)"
-

Jenkinsfile

@@ -2,8 +2,8 @@ pipeline {
     agent {
         docker {
             label 'docker-x86_64'
-            image 'retropikzel1/compile-r7rs'
+            image 'debian'
-            args '--user=root --privileged -v /var/run/docker.socket:/var/run/docker.socket'
+            args '--user=root --privileged -v /var/run/docker.sock:/var/run/docker.sock'
         }
     }
 
@@ -13,23 +13,13 @@ pipeline {
     }
 
     parameters {
-        //string(name: 'SCHEMES', defaultValue: 'chibi chicken gauche kawa racket sagittarius stklos', description: '')
+        string(name: 'SCHEMES', defaultValue: 'chibi chicken kawa racket sagittarius stklos', description: '')
-        string(name: 'SCHEMES', defaultValue: 'sagittarius', description: '')
     }
 
     stages {
-        stage('Build compile-r7rs') {
+        stage('Init') {
-            agent {
-                docker {
-                    image "schemers/chicken:5"
-                    label "docker-x86_64"
-                }
-            }
             steps {
-                sh "git clone https://gitea.scheme.org/Retropikzel/compile-r7rs.git"
+                sh "apt-get update && apt-get install -y make docker.io git"
-                dir("compile-r7rs") {
-                    sh "make build-chicken"
-                }
             }
         }
 
@@ -43,7 +33,7 @@ pipeline {
                         }
                         stage("${SCHEME}") {
                             catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
-                                sh "make SCHEME=${SCHEME} test-in-docker"
+                                sh "make SCHEME=${SCHEME} test-docker"
                             }
                         }
                     }

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} \
@@ -28,14 +29,13 @@ build:
 		--description="Portable foreign function interface for R7RS Schemes" \
 		--test=test.scm \
 	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/kawa-primitives.sld \
 	foreign/c/mosh-primitives.sld \
 	foreign/c/racket-primitives.sld \
-	foreign/c/sagittarius-primitives.sld \
+	foreign/c/stklos-primitives.sld \
 	foreign/c/ypsilon-primitives.sld
 
 build-gauche:
@@ -48,7 +48,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,12 +70,9 @@ 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 run -it -v "${PWD}:/workdir" -w /workdir retropikzel1/compile-r7rs sh -c \
+	docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=retropikzel-foreign-c-test-${SCHEME} -f Dockerfile.test .
-		"make SCHEME=${SCHEME} SNOW_CHIBI_ARGS=--always-yes install 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"
 
 libtest.o: tests/c-src/libtest.c
 	${CC} ${CFLAGS} -o libtest.o -fPIC -c tests/c-src/libtest.c -I./include ${LDFLAGS}

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,23 +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)))
+    ;(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
           c-type-align

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,104 @@
+(define size-of-type
+  (lambda (type)
+    (cond ((eq? type 'int8) size-of-int8_t)
+          ((eq? type 'uint8) size-of-uint8_t)
+          ((eq? type 'int16) size-of-int16_t)
+          ((eq? type 'uint16) size-of-uint16_t)
+          ((eq? type 'int32) size-of-int32_t)
+          ((eq? type 'uint32) size-of-uint32_t)
+          ((eq? type 'int64) size-of-int64_t)
+          ((eq? type 'uint64) size-of-uint64_t)
+          ((eq? type 'char) size-of-char)
+          ((eq? type 'unsigned-char) size-of-char)
+          ((eq? type 'short) size-of-short)
+          ((eq? type 'unsigned-short) size-of-unsigned-short)
+          ((eq? type 'int) size-of-int)
+          ((eq? type 'unsigned-int) size-of-unsigned-int)
+          ((eq? type 'long) size-of-long)
+          ((eq? type 'unsigned-long) size-of-unsigned-long)
+          ((eq? type 'float) size-of-float)
+          ((eq? type 'double) size-of-double)
+          ((eq? type 'pointer) size-of-void*)
+          ((eq? type 'void) 0)
+          ((eq? type 'callback) size-of-void*)
+          (else #f))))
+
+(define align-of-type
+  (lambda (type)
+    (cond ((eq? type 'int8) align-of-int8_t)
+          ((eq? type 'uint8) align-of-uint8_t)
+          ((eq? type 'int16) align-of-int16_t)
+          ((eq? type 'uint16) align-of-uint16_t)
+          ((eq? type 'int32) align-of-int32_t)
+          ((eq? type 'uint32) align-of-uint32_t)
+          ((eq? type 'int64) align-of-int64_t)
+          ((eq? type 'uint64) align-of-uint64_t)
+          ((eq? type 'char) align-of-char)
+          ((eq? type 'unsigned-char) align-of-char)
+          ((eq? type 'short) align-of-short)
+          ((eq? type 'unsigned-short) align-of-unsigned-short)
+          ((eq? type 'int) align-of-int)
+          ((eq? type 'unsigned-int) align-of-unsigned-int)
+          ((eq? type 'long) align-of-long)
+          ((eq? type 'unsigned-long) align-of-unsigned-long)
+          ((eq? type 'float) align-of-float)
+          ((eq? type 'double) align-of-double)
+          ((eq? type 'pointer) align-of-void*)
+          ((eq? type 'void) 0)
+          ((eq? type 'callback) align-of-void*)
+          (else #f))))
+
+(define shared-object-load
+  (lambda (path options)
+    (open-shared-library path)))
+
+(define type->native-type
+  (lambda (type)
+    (cond ((equal? type 'int8) 'int8_t)
+          ((equal? type 'uint8) 'uint8_t)
+          ((equal? type 'int16) 'int16_t)
+          ((equal? type 'uint16) 'uint16_t)
+          ((equal? type 'int32) 'int32_t)
+          ((equal? type 'uint32) 'uint32_t)
+          ((equal? type 'int64) 'int64_t)
+          ((equal? type 'uint64) 'uint64_t)
+          ((equal? type 'char) 'char)
+          ((equal? type 'unsigned-char) '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) 'void*)
+          ((equal? type 'void) 'void)
+          ((equal? type 'callback) 'callback)
+          (else #f))))
+
+(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
+                        (type->native-type return-type)
+                        c-name
+                        (map type->native-type argument-types))))))
+
+(define-syntax define-c-callback
+  (syntax-rules ()
+    ((_ scheme-name return-type argument-types procedure)
+     (define scheme-name
+       (make-c-callback (type->native-type return-type)
+                        (map type->native-type argument-types)
+                        procedure)))))
+
+(define c-bytevector?
+  (lambda (object)
+    (pointer? object)))
+
+(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
+(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
+(define c-bytevector-pointer-set! pointer-set-c-pointer!)
+(define c-bytevector-pointer-ref pointer-ref-c-pointer)

foreign/c/gauche-primitives.sld

@@ -6,8 +6,7 @@
           (scheme file)
           (scheme inexact)
           (scheme process-context)
-          (gauche base)
+          (gauche ffi))
-          (foreign c primitives gauche))
   (export size-of-type
           align-of-type
           shared-object-load

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

foreign/c/sagittarius-primitives.scm

@@ -102,48 +102,3 @@
 (define c-bytevector-u8-ref pointer-ref-c-uint8_t)
 (define c-bytevector-pointer-set! pointer-set-c-pointer!)
 (define c-bytevector-pointer-ref pointer-ref-c-pointer)
-
-#;(define 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 (char->integer 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-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) (integer->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)))))
-

foreign/c/stklos-primitives.scm

@@ -1,3 +1,20 @@
+(define foreign-c:string-split
+  (lambda (str mark)
+    (let* ((str-l (string->list str))
+           (res (list))
+           (last-index 0)
+           (index 0)
+           (splitter (lambda (c)
+                       (cond ((char=? c mark)
+                              (begin
+                                (set! res (append res (list (string-copy str last-index index))))
+                                (set! last-index (+ index 1))))
+                             ((equal? (length str-l) (+ index 1))
+                              (set! res (append res (list (string-copy str last-index (+ index 1)))))))
+                       (set! index (+ index 1)))))
+      (for-each splitter str-l)
+      res)))
+
 (define type->native-type
   (lambda (type)
     (cond ((equal? type 'int8) :char)