Bring things to new compile-r7rs

dockerfiles/Dockerfile.test

@@ -25,5 +25,4 @@ COPY --from=build /compile-r7rs /compile-r7rs
 RUN cd /compile-r7rs && make install
 ARG SCHEME=chibi
 ENV COMPILE_R7RS=${SCHEME}
-RUN mkdir -p ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm
 ENV GUILE_AUTO_COMPILE=0

foreign/c.sld

@@ -293,57 +293,7 @@
           ;; c-variable
           ;define-c-variable (?)
           )
-   (begin
+  (cond-expand
-     (define type->libffi-type-number
-       (lambda (type)
-         (cond ((equal? type 'int8) 1)
-               ((equal? type 'uint8) 2)
-               ((equal? type 'int16) 3)
-               ((equal? type 'uint16) 4)
-               ((equal? type 'int32) 5)
-               ((equal? type 'uint32) 6)
-               ((equal? type 'int64) 7)
-               ((equal? type 'uint64) 8)
-               ((equal? type 'char) 9)
-               ((equal? type 'unsigned-char) 10)
-               ((equal? type 'short) 11)
-               ((equal? type 'unsigned-short) 12)
-               ((equal? type 'int) 13)
-               ((equal? type 'unsigned-int) 14)
-               ((equal? type 'long) 15)
-               ((equal? type 'unsigned-long) 16)
-               ((equal? type 'float) 17)
-               ((equal? type 'double) 18)
-               ((equal? type 'void) 19)
-               ((equal? type 'pointer) 20)
-               ((equal? type 'pointer-address) 21)
-               ((equal? type 'callback) 22)
-               (else (error "Undefined type" type)))))
-      (define c-bytevector-get
-        (lambda (pointer type offset)
-          (cond ((equal? type 'int8) (c-bytevector-s8-ref pointer offset))
-                ((equal? type 'uint8) (c-bytevector-u8-ref pointer offset))
-                ((equal? type 'int16) (c-bytevector-s16-ref pointer offset))
-                ((equal? type 'uint16) (c-bytevector-u16-ref pointer offset))
-                ((equal? type 'int32) (c-bytevector-s32-ref pointer offset))
-                ((equal? type 'uint32) (c-bytevector-u32-ref pointer offset))
-                ((equal? type 'int64) (c-bytevector-s64-ref pointer offset))
-                ((equal? type 'uint64) (c-bytevector-u64-ref pointer offset))
-                ((equal? type 'char) (integer->char (c-bytevector-s8-ref pointer offset)))
-                ((equal? type 'unsigned-char) (integer->char (c-bytevector-u8-ref pointer offset)))
-                ((equal? type 'short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'short)))
-                ((equal? type 'unsigned-short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-short)))
-                ((equal? type 'int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'int)))
-                ((equal? type 'unsigned-int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-int)))
-                ((equal? type 'long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'long)))
-                ((equal? type 'unsigned-long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-long)))
-                ((equal? type 'float) (c-bytevector-ieee-single-native-ref pointer offset))
-                ((equal? type 'double) (c-bytevector-ieee-double-native-ref pointer offset))
-                ((equal? type 'pointer) (c-bytevector-pointer-ref pointer offset))
-                ((not (equal? type 'void)) (error "No such foreign type" type))
-                ;; Return unspecified on purpose if type is void
-                ))))
-  #;(cond-expand
     (chicken-6 (include-relative "c/internal.scm"))
     (else (include "c/internal.scm")))
   (cond-expand
@@ -352,7 +302,10 @@
                        foreign-safe-lambda
                        void)
                (include "c/primitives/chicken.scm"))
-    (chicken-6 (include-relative "c/primitives/chicken.scm"))
+    (chicken-6 (export foreign-declare
+                       foreign-safe-lambda
+                       void)
+      (include-relative "c/primitives/chicken.scm"))
     ;(cyclone (include "c/primitives/cyclone.scm"))
     (gambit (include "c/primitives/gambit.scm"))
     (gauche (include "c/primitives/gauche/define-c-procedure.scm"))
@@ -378,8 +331,8 @@
                )
     (else (include "c/main.scm")
           (include "c/libc.scm")
-          ;(include "c/struct.scm")
           (include "c/c-bytevectors.scm")
           (include "c/pointer.scm")
           ;(include "c/array.scm")
+          ;(include "c/struct.scm")
           )))

foreign/c/libc.scm

@@ -4,4 +4,4 @@
   (else
     (define libc-name
       (cond ((get-environment-variable "BE_HOST_CPU") "root") ; Haiku
-            (else "c")))))
+	    (else "c")))))

foreign/c/primitives/chicken.scm

@@ -180,47 +180,3 @@
 (define c-bytevector-pointer-set!
   (lambda (c-bytevector k pointer)
     (pointer-u64-set! (pointer+ c-bytevector k) (pointer->address pointer))))
-
-#;(define pffi-pointer-set!
-  (lambda (pointer type offset value)
-    (cond
-      ((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value))
-      ((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value))
-      ((equal? type 'int16) (pointer-s16-set! (pointer+ pointer offset) value))
-      ((equal? type 'uint16) (pointer-u16-set! (pointer+ pointer offset) value))
-      ((equal? type 'int32) (pointer-s32-set! (pointer+ pointer offset) value))
-      ((equal? type 'uint32) (pointer-u32-set! (pointer+ pointer offset) value))
-      ((equal? type 'int64) (pointer-s64-set! (pointer+ pointer offset) value))
-      ((equal? type 'uint64) (pointer-u64-set! (pointer+ pointer offset) value))
-      ((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) (char->integer value)))
-      ((equal? type 'short) (pointer-s8-set! (pointer+ pointer offset) value))
-      ((equal? type 'unsigned-short) (pointer-u8-set! (pointer+ pointer offset) value))
-      ((equal? type 'int) (pointer-s32-set! (pointer+ pointer offset) value))
-      ((equal? type 'unsigned-int) (pointer-u32-set! (pointer+ pointer offset) value))
-      ((equal? type 'long) (pointer-s32-set! (pointer+ pointer offset) value))
-      ((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value))
-      ((equal? type 'float) (pointer-f32-set! (pointer+ pointer offset) value))
-      ((equal? type 'double) (pointer-f64-set! (pointer+ pointer offset) value))
-      ((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address value))))))
-
-#;(define pffi-pointer-get
-  (lambda (pointer type offset)
-    (cond
-      ((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset)))
-      ((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset)))
-      ((equal? type 'int16) (pointer-s16-ref (pointer+ pointer offset)))
-      ((equal? type 'uint16) (pointer-u16-ref (pointer+ pointer offset)))
-      ((equal? type 'int32) (pointer-s32-ref (pointer+ pointer offset)))
-      ((equal? type 'uint32) (pointer-u32-ref (pointer+ pointer offset)))
-      ((equal? type 'int64) (pointer-s64-ref (pointer+ pointer offset)))
-      ((equal? type 'uint64) (pointer-u64-ref (pointer+ pointer offset)))
-      ((equal? type 'char) (integer->char (pointer-s8-ref (pointer+ pointer offset))))
-      ((equal? type 'short) (pointer-s8-ref (pointer+ pointer offset)))
-      ((equal? type 'unsigned-short) (pointer-u8-ref (pointer+ pointer offset)))
-      ((equal? type 'int) (pointer-s32-ref (pointer+ pointer offset)))
-      ((equal? type 'unsigned-int) (pointer-u32-ref (pointer+ pointer offset)))
-      ((equal? type 'long) (pointer-s32-ref (pointer+ pointer offset)))
-      ((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset)))
-      ((equal? type 'float) (pointer-f32-ref (pointer+ pointer offset)))
-      ((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset)))
-      ((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset)))))))