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

Bring things to new compile-r7rs

This commit is contained in:
retropikzel 2025-07-19 17:47:22 +03:00
parent 47aa7cb309
commit 733e1a01d2
4 changed files with 7 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
dockerfiles/Dockerfile.test
View File

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

59
foreign/c.sld
View File

@ -293,57 +293,7 @@
;; c-variable
;define-c-variable (?)
)
(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
(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")
)))

2
foreign/c/libc.scm
View File

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

44
foreign/c/primitives/chicken.scm
View File

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