diff --git a/dockerfiles/Dockerfile.test b/dockerfiles/Dockerfile.test index 337d70d..8b70621 100644 --- a/dockerfiles/Dockerfile.test +++ b/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 diff --git a/foreign/c.sld b/foreign/c.sld index 9b3e12c..08d796d 100644 --- a/foreign/c.sld +++ b/foreign/c.sld @@ -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") ))) diff --git a/foreign/c/libc.scm b/foreign/c/libc.scm index 27ec05f..f2e2c25 100644 --- a/foreign/c/libc.scm +++ b/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"))))) diff --git a/foreign/c/primitives/chicken.scm b/foreign/c/primitives/chicken.scm index f4a17bd..8089a6d 100644 --- a/foreign/c/primitives/chicken.scm +++ b/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)))))))