Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fixing tests

This commit is contained in:
retropikzel 2025-07-10 08:22:41 +03:00
parent 1568976988
commit 3ae1270518
3 changed files with 53 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
dockerfiles/Dockerfile.snow-chibi-install-test
View File

@ -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 \

2
dockerfiles/Dockerfile.test
View File

@ -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 \

52
foreign/c.sld
View File

@ -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