From 3ae1270518666642614a2a8ca149f0d63fade1dc Mon Sep 17 00:00:00 2001
From: retropikzel <retropikzel@iki.fi>
Date: Thu, 10 Jul 2025 08:22:41 +0300
Subject: [PATCH] Fixing tests

---
 .../Dockerfile.snow-chibi-install-test        |  2 +-
 dockerfiles/Dockerfile.test                   |  2 +-
 foreign/c.sld                                 | 52 ++++++++++++++++++-
 3 files changed, 53 insertions(+), 3 deletions(-)

diff --git a/dockerfiles/Dockerfile.snow-chibi-install-test b/dockerfiles/Dockerfile.snow-chibi-install-test
index dbe49ba..8abbb10 100644
--- a/dockerfiles/Dockerfile.snow-chibi-install-test
+++ b/dockerfiles/Dockerfile.snow-chibi-install-test
@@ -6,7 +6,7 @@ RUN git clone https://github.com/Retropikzel/compile-r7rs.git --depth=1
 RUN cd compile-r7rs && make && make install
 
 ARG SCHEME=chibi
-FROM schemers/${SCHEME}
+FROM schemers/${SCHEME}:head
 RUN apt-get update && apt-get install -y \
     build-essential \
     git \
diff --git a/dockerfiles/Dockerfile.test b/dockerfiles/Dockerfile.test
index 2743318..77b7e9a 100644
--- a/dockerfiles/Dockerfile.test
+++ b/dockerfiles/Dockerfile.test
@@ -7,7 +7,7 @@ RUN ls
 RUN cd compile-r7rs && make && make install
 
 ARG SCHEME=chibi
-FROM schemers/${SCHEME}
+FROM schemers/${SCHEME}:head
 RUN apt-get update && apt-get install -y \
     build-essential \
     git \
diff --git a/foreign/c.sld b/foreign/c.sld
index 121c725..655a8a2 100644
--- a/foreign/c.sld
+++ b/foreign/c.sld
@@ -300,7 +300,57 @@
           ;; c-variable
           ;define-c-variable (?)
           )
-  (cond-expand
+   (begin
+     (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