diff --git a/foreign/c.sld b/foreign/c.sld index 707d704..594f52b 100644 --- a/foreign/c.sld +++ b/foreign/c.sld @@ -207,7 +207,7 @@ (ypsilon c-ffi) (ypsilon c-types) (only (core) define-macro syntax-case)))) - (export ;; Primitives + (export ;;;; Primitives c-size-of define-c-library define-c-procedure @@ -218,11 +218,12 @@ c-bytevector-pointer-set! c-bytevector-pointer-ref - ;; c-bytevector + ;;;; c-bytevector + make-c-bytevector + make-c-null + c-null? + c-free native-endianness - ;; TODO Docs for all of these - ;c-bytevector->address - ;address->c-bytevector c-bytevector-s8-set! c-bytevector-s8-ref c-bytevector-s16-set! @@ -261,23 +262,14 @@ c-bytevector-ieee-double-native-set! c-bytevector-ieee-double-ref c-bytevector-ieee-double-native-ref - - ;; c-bytevector - make-c-bytevector - ;c-bytevector ;; TODO docs, tests - make-c-null - c-null? - c-free - - - c-string-length ;; TODO Documentation, Testing bytevector->c-bytevector c-bytevector->bytevector - call-with-address-of-c-bytevector ;; Todo Documentation + call-with-address-of + string->c-utf8 c-utf8->string - ;c-bytevector-u8-ref ;; TODO Documentation, Testing + ;c-string-length ;; TODO Documentation, Testing ;; c-struct ;pffi-define-struct;define-c-struct @@ -301,10 +293,8 @@ ;define-c-variable (?) ) (cond-expand - (chicken-6 (include-relative "c/types.scm") - (include-relative "c/c-bytevector-get.scm")) - (else (include "c/types.scm") - (include "c/c-bytevector-get.scm"))) + (chicken-6 (include-relative "c/internal.scm")) + (else (include "c/internal.scm"))) (cond-expand (chibi (include "c/primitives/chibi.scm")) (chicken-5 (export foreign-declare diff --git a/foreign/c/c-bytevector-get.scm b/foreign/c/internal.scm similarity index 67% rename from foreign/c/c-bytevector-get.scm rename to foreign/c/internal.scm index 1db5409..1b3b931 100644 --- a/foreign/c/c-bytevector-get.scm +++ b/foreign/c/internal.scm @@ -1,3 +1,29 @@ +(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)) diff --git a/foreign/c/pointer.scm b/foreign/c/pointer.scm index 7e0e45d..c2b2cf0 100644 --- a/foreign/c/pointer.scm +++ b/foreign/c/pointer.scm @@ -111,7 +111,7 @@ (cond-expand ;(kawa #t) ; Defined in kawa.scm - (else (define-syntax call-with-address-of-c-bytevector + (else (define-syntax call-with-address-of (syntax-rules () ((_ input-pointer thunk) (let ((address-pointer (make-c-bytevector (c-size-of 'pointer)))) diff --git a/foreign/c/types.scm b/foreign/c/types.scm deleted file mode 100644 index 8716a29..0000000 --- a/foreign/c/types.scm +++ /dev/null @@ -1,25 +0,0 @@ -(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))))) diff --git a/tests/addressof.scm b/tests/addressof.scm index 966be34..9ff3a68 100644 --- a/tests/addressof.scm +++ b/tests/addressof.scm @@ -71,7 +71,7 @@ (write value) (newline))))) -;; call-with-address-of-c-bytevector +;; call-with-address-of (define-c-library c-testlib '("libtest.h") @@ -79,7 +79,7 @@ '((additional-paths ("." "./tests")))) -(print-header 'call-with-address-of-c-bytevector) +(print-header 'call-with-address-of) (define-c-procedure test-passing-pointer-address c-testlib @@ -92,7 +92,7 @@ (assert equal? (= (c-bytevector-s32-native-ref input-pointer 0) 100) #t) (debug (c-bytevector-s32-native-ref input-pointer 0)) (debug input-pointer) -(call-with-address-of-c-bytevector +(call-with-address-of input-pointer (lambda (address) (test-passing-pointer-address input-pointer address)))